## api-match-g.pkg
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib# 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 typechecking
# of apis and generics.
### "If language is not correct,
### then what is said is not what is meant.
### If what is said is not what is meant,
### then what ought to be done remains undone."
###
### -- Kong Fu Zi
### (aka "Confucius")
stipulate
package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.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 mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package mp = 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 sta = stamp; # stamp is from src/lib/compiler/front/typer-stuff/basics/stamp.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package trj = typer_junk; # typer_junk is from src/lib/compiler/front/typer/main/typer-junk.pkgherein
api Api_Match {
package expand_generic
: Expand_Generic; # Expand_Generic is from src/lib/compiler/front/typer/modules/expand-generic-g.pkg # These four functions are only called
# inside type-package-language.pkg.
# thin_package() and cast_package() are a pair.
#
# Essentially, the first removes mld::A_PACKAGE.an_api.elements
# which are not declared in the constraining
# API, while the second converts mld::A_PACKAGE.an_api.elements
# to abstract form as required by the constraining API.
#
# We apply both in order to implement strong
# sealing (SML ":>", Mythryl ":") -- see
#
# type_constrained_package
#
# in src/lib/compiler/front/typer/main/type-package-language-g.pkg #
# To implement weak sealing
# (SML ":", Mythry ": (weak) ")
# we call the first but not the second.
thin_package:
{ constrained_package: mld::Package, # Check this package
constraining_api: mld::Api, # against this API.
package_expression: mld::Package_Expression,
module_stamp_or_null: Null_Or( sta::Stamp ),
debruijn_depth: di::Debruijn_Depth,
typerstore: mld::Typerstore,
inverse_path: ip::Inverse_Path,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff: trj::Per_Compile_Stuff
}
->
{ result_declaration: ds::Declaration,
result_package: mld::Package,
coerced_package_expression: mld::Package_Expression # a mld::COERCED_PACKAGE coercing original package_expression to proper api.
};
cast_package:
{ constrained_package: mld::Package,
constraining_api: mld::Api,
package_expression: mld::Package_Expression,
debruijn_depth: di::Debruijn_Depth,
typerstore: mld::Typerstore,
inverse_path: ip::Inverse_Path,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff: trj::Per_Compile_Stuff
}
->
{ result_declaration: ds::Declaration,
result_package: mld::Package,
result_expression: mld::Package_Expression
};
match_generic: { an_api: mld::Generic_Api,
a_generic: mld::Generic,
generic_expression: mld::Generic_Expression,
debruijn_depth: di::Debruijn_Depth,
typerstore: mld::Typerstore,
inverse_path: ip::Inverse_Path,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff: trj::Per_Compile_Stuff
}
->
{ result_declaration: ds::Declaration,
result_generic: mld::Generic,
result_expression: mld::Generic_Expression
};
apply_generic: { a_generic: mld::Generic,
generic_expression: mld::Generic_Expression,
arg_package: mld::Package,
arg_expression: mld::Package_Expression,
module_stamp_or_null: Null_Or( sta::Stamp ),
debruijn_depth: di::Debruijn_Depth,
stamppath_context: spc::Context,
symbolmapstack: syx::Symbolmapstack,
inverse_path: ip::Inverse_Path,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff: trj::Per_Compile_Stuff
}
->
{ result_declaration: ds::Declaration,
result_package: mld::Package,
result_expression: mld::Package_Expression
};
debugging: Ref( Bool );
show_apis: Ref( Bool );
}; # Api Api_Match
end; # stipulate
# We use a generic to factor out dependencies on highcode:
#
# This generic is invoked in
# src/lib/compiler/front/semantic/modules/api-match.pkg#
stipulate
package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package ep = stamppath; # stamppath is from src/lib/compiler/front/typer-stuff/modules/stamppath.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 id = inlining_data; # inlining_data is from src/lib/compiler/front/typer-stuff/basics/inlining-data.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package lms = list_mergesort; # list_mergesort is from src/lib/src/list-mergesort.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 mp = stamppath; # stamppath is from src/lib/compiler/front/typer-stuff/modules/stamppath.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package spc = stamppath_context; # stamppath_context is from src/lib/compiler/front/typer-stuff/modules/stamppath-context.pkg package sta = stamp; # stamp is from src/lib/compiler/front/typer-stuff/basics/stamp.pkg package sxe = symbolmapstack_entry; # symbolmapstack_entry is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack-entry.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package syp = symbol_path; # symbol_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.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 tj = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package trj = typer_junk; # typer_junk is from src/lib/compiler/front/typer/main/typer-junk.pkg package tro = typerstore; # typerstore is from src/lib/compiler/front/typer-stuff/modules/typerstore.pkg package tyd = typer_debugging; # typer_debugging is from src/lib/compiler/front/typer/main/typer-debugging.pkg package upl = unparse_package_language; # unparse_package_language is from src/lib/compiler/front/typer/print/unparse-package-language.pkg package vac = variables_and_constructors; # variables_and_constructors is from src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg Pp = pp::Pp;
herein
generic package api_match_g (package expand_generic: Expand_Generic;) # Expand_Generic is from src/lib/compiler/front/typer/modules/expand-generic-g.pkg # expand_generic is from src/lib/compiler/front/semantic/modules/expand-generic.pkg : (weak) Api_Match # Api_Match is from src/lib/compiler/front/typer/modules/api-match-g.pkg {
# Export our parameter for client packages:
#
package expand_generic = expand_generic;
# A local abbreviation:
#
package gxs = expand_generic::generics_expansion_junk;
exception BAD_NAMING;
no_undo_log = REF (NULL: Null_Or(List(Void -> Void))); # This REF will never get set to anything else, so it is harmless.
show_apis = REF FALSE;
debugging = typer_control::api_match_debugging; # eval: set_control "typechecker::api_match_debugging" "TRUE";
# To use the above "debugging" flag you might (say) do
#
# linux$ cd src/app/tut/test
# linux$ touch test.pkg
# linux$ my
# eval: set_control "typechecker::api_match_debugging" "TRUE";
# eval: make "test.lib";
#
# This will spew debug printouts of various datastructures
# as the code in this file runs.
say = control_print::say;
#
fun if_debugging_say (msg: String)
=
if *debugging say msg; say "\n"; fi;
#
fun bug msg
=
err::impossible ("api_match:" + msg);
nth = list::nth;
#
fun for' l f
=
apply f l;
#
fun unwrap_typecon_entry (mld::TYPE_ENTRY x) => x;
unwrap_typecon_entry _ => bug "unwrap_typecon_entry";
end;
# Given a list of symbols created by
# src/lib/compiler/front/basics/map/symbol.pkg # return "a, b, c" or such:
#
fun symbols_to_string [ ] => "";
symbols_to_string [n] => sy::name n;
symbols_to_string (n ! r)
=>
cat (sy::name n ! fold_backward
(\\ (n, b) = (", " ! sy::name n ! b))
[]
r);
end;
bogus_type = tdt::UNDEFINED_TYPOID;
# Bogus coercion expressions returned by the matching functions.
# These should never be evaluated.
#
bogus_package_expression = mld::VARIABLE_PACKAGE [];
bogus_generic_expression = mld::VARIABLE_GENERIC [];
#
fun if_debugging_show_package (msg, pkg)
=
tyd::with_internals (\\ () = tyd::debug_print
debugging
( msg,
(\\ pps = \\ pkg = upl::unparse_package pps (pkg, syx::empty, 100)),
pkg
)
);
#
fun exception_representation (vh::EXCEPTION _, varhome) => vh::EXCEPTION varhome;
exception_representation _ => bug "unexpected Valcon_Form in exception_representation";
end;
#
fun is_named (THE _) => TRUE;
is_named _ => FALSE;
end;
anonymous_package_symbol = sy::make_package_symbol "<anonymous_package>";
anonymous_generic_symbol = sy::make_generic_symbol "<anonymous_generic>";
generic_api_parameter_typechecked_package_symbol
=
sy::make_package_symbol
"<generic_api_parameter_evaluation>";
#
fun ident _ = ();
# Match an abstract version of a type with its actual version.
# Return TRUE and the new instantiations if package type > api type
#
fun try_unifying_pkg_with_api_type
( type_per_api,
type_per_pkg,
inlining_data
)
:
( List( tdt::Typoid ),
List( tdt::Typevar_Ref ),
tdt::Typoid,
Bool # TRUE iff the two match.
)
=
{ type_per_pkg = tj::drop_resolved_typevars type_per_pkg; # Drop redundant RESOLVED_TYPEVAR indirections.
type_per_api = tj::drop_resolved_typevars type_per_api; # Drop redundant RESOLVED_TYPEVAR indirections.
(tj::instantiate_if_typescheme (type_per_pkg, syx::empty, [ "try_unifying_pkg_with_api_type" ])) -> (type_per_pkg', fresh_meta_typevars_for_pkg);
(tj::instantiate_if_typescheme (type_per_api, syx::empty, [ "try_unifying_pkg_with_api_type" ])) -> (type_per_api', fresh_meta_typevars_for_api);
paired_lists::apply unify (fresh_meta_typevars_for_pkg, fresh_meta_typevars_for_api)
where
fun unify (type1, type2)
=
unify_typoids::unify_typoids ("1", "2", type1, type2, ["try_unifying_pkg_with_api_type"], no_undo_log );
end;
# This is a gross hack. Inlining-information such as primops
# (or inline-able expressions) are propagated through api
# matching. However, their types may change. The following code
# is to figure out the proper type application arguments, insttys.
# The typechecker has a similar hack. We will clean this up in the
# future (ZHONG).
#
# Change: The hack is gone, but I am not sure whether the code
# below could be further simplified. (inline_baseop now has mandatory
# type information, and this type information is always correctly
# provided by base-types-and-ops.pkg.) (Blume, 1/2001)
types = case (gxs::param::inlining_data_to_my_type inlining_data)
#
THE type_per_inlining_data
=>
{ (tj::instantiate_if_typescheme (type_per_inlining_data, syx::empty, [ "try_unifying_pkg_with_api_type" ]))
->
(type_per_inlining_data', fresh_meta_typevars_for_inlining_data);
unify_typoids::unify_typoids ("1", "2", type_per_inlining_data', type_per_pkg', ["try_unifying_pkg_with_api_type"], no_undo_log)
except
_ = ();
fresh_meta_typevars_for_inlining_data;
};
NULL => fresh_meta_typevars_for_pkg;
esac;
types_matched
=
{ unify_typoids::unify_typoids ("1", "2", type_per_pkg', type_per_api', ["try_unifying_pkg_with_api_type"], no_undo_log);
TRUE;
}
except
_ = FALSE;
typevar_refs
=
map tj::typevar_of_typoid
fresh_meta_typevars_for_pkg; # Q: Should I use fresh_meta_typevars_for_api here instead, why fresh_meta_typevars_for_pkg?
# A: They've been unified, it makes no difference -- they will be identical at this point.
(types, typevar_refs, type_per_api', types_matched);
}; # fun try_unifying_pkg_with_api_type
# This function does about 80%
# of what the above function does.
#
# This one gets used in thin_package();
# the above gets used in cast_package().
#
# This one gets called only when the pkg and api types are known to match;
# the above gets called when this is not known, hence returns that information.
#
fun unify_pkg_with_api_type { type_per_api, type_per_pkg, inlining_data }
:
( List( tdt::Typoid ),
List( tdt::Typevar_Ref )
)
=
{ type_per_pkg = tj::drop_resolved_typevars type_per_pkg; # Drop redundant RESOLVED_TYPEVAR indirections.
#
(tj::instantiate_if_typescheme (type_per_pkg, syx::empty, [ "unify_pkg_with_api_type" ])) -> (type_per_pkg', fresh_meta_typevars_for_pkg);
(tj::instantiate_if_typescheme (type_per_api, syx::empty, [ "unify_pkg_with_api_type" ])) -> (type_per_api', fresh_meta_typevars_for_api);
types = case (gxs::param::inlining_data_to_my_type inlining_data)
#
THE type_per_inlining_data
=>
{ (tj::instantiate_if_typescheme (type_per_inlining_data, syx::empty, [ "unify_pkg_with_api_type" ]))
->
(type_per_inlining_data', fresh_meta_typevars_for_inlining_data);
unify_typoids::unify_typoids ("1", "2", type_per_inlining_data', type_per_pkg', ["unify_pkg_with_api_type"], no_undo_log)
except
_ = ();
fresh_meta_typevars_for_inlining_data;
};
NULL => fresh_meta_typevars_for_pkg;
esac;
(unify_typoids::unify_typoids ("1", "2", type_per_pkg', type_per_api', ["unify_pkg_with_api_type"], no_undo_log))
except
_ = bug "unexpected types in unify_pkg_with_api_type";
typevar_refs = map tj::typevar_of_typoid
fresh_meta_typevars_for_api;
(types, typevar_refs);
};
##########################################################################
#
# thin_package': Matching a package against an api.
#
# WARNING: rpath is an inverse stamppath, so it has to be
# reversed to produce an stamppath.
#
fun thin_package'
(
constrained_pkg
as
mld::A_PACKAGE {
an_api => mld::API {
stamp => pkg_api_stamp,
api_elements => pkg_api_elements,
...
},
typechecked_package
as
{ stamp => pkg_stamp,
typerstore => package_typerstore,
...
},
varhome => constrained_pkg_varhome,
inlining_data => constrained_pkg_inline_info
}
: mld::Package,
constraining_api
as
mld::API {
stamp => constraining_api_stamp,
closed => constraining_api_is_closed,
contains_generic => constraining_api_contains_generic,
api_elements => constraining_api_elements,
...
}
: mld::Api,
package_name: sy::Symbol,
debruijn_depth: di::Debruijn_Depth,
match_typerstore: mld::Typerstore,
rpath: List( sta::Stamp ),
inverse_path: ip::Inverse_Path,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff
as
{ make_fresh_stamp,
issue_highcode_codetemp => make_var,
error_fn,
...
}
: trj::Per_Compile_Stuff
)
:
( ds::Declaration, # Thinned declaration (Becomes PACKAGE_LET.declaration in eventual deep syntax tree.)
mld::Package, # Thinned package (Becomes PACKAGE_LET.expression in eventual deep syntax tree.)
mld::Package_Expression # Only for internal generics typechecking use: This will be used to mld::COERCED_PACKAGE original package_expression to correct api.
)
=>
{ err = error_fn source_code_region;
#
fun unparse_api pps an_api
=
upl::unparse_api pps (an_api, symbolmapstack, 2);
fun unparse_pkg pps pkg
=
upl::unparse_package pps (pkg, syx::empty, 2);
fun unparse_pkg_name pps pkg
=
upl::unparse_package_name pps (pkg, syx::empty);
title = "thin_package'/TOP - constraining_api:";
tyd::debug_print show_apis (title, unparse_api, constraining_api);
#
fun unify_typoids { type_per_api, type_per_pkg, inlining_data, name }
:
( List( tdt::Typoid ),
List( tdt::Typevar_Ref )
)
=
if (tj::pkg_typoid_matches_api_typoid { type_per_api, type_per_pkg })
#
(unify_pkg_with_api_type { type_per_api, type_per_pkg, inlining_data })
->
(types, typevar_refs);
(types, typevar_refs);
else
err err::ERROR
"value type in package doesn't match api declaration"
(\\ pp
=
{ unparse_type::reset_unparse_type ();
pp.newline();
apply pp.lit [" name: ", sy::name name];
pp.newline();
pp.lit "type_per_api: ";
unparse_type::unparse_typoid symbolmapstack pp type_per_api;
pp.newline();
pp.lit "type_per_pkg: ";
unparse_type::unparse_typoid symbolmapstack pp type_per_pkg;
}
);
([],[]);
fi;
#
fun complain s = err err::ERROR s err::null_error_body;
fun complain' x = { complain x; raise exception BAD_NAMING;};
# Compute mismatches between the API and package
# definitions of a sumtype.
#
# We are given two sorted lists of symbols:
# o The sumtype constructor list per API definition,
# o The sumtype constructor list per pkg definition.
#
# We return two lists:
# o Data constructors appearing only the API version,
# o Data constructors appearing only the package version.
#
# We depend on the fact that
# data constructors have been
# sorted by name:
#
fun find_unmatched_valcons (in_api, in_pkg)
=
find_unmatched (in_api, in_pkg, [], [])
where
fun find_unmatched
( l1 as dc1 ! r1, # "dc" == "data constructor"; "r" == "rest"
l2 as dc2 ! r2,
in_api_only, #
in_pkg_only #
)
=>
if (sy::eq (dc1, dc2))
find_unmatched (r1, r2, in_api_only, in_pkg_only);
else
sy::symbol_gt (dc1, dc2) ?? find_unmatched ( l1, r2, in_api_only, dc2 ! in_pkg_only )
:: find_unmatched ( r1, l2, dc1 ! in_api_only, in_pkg_only );
fi;
find_unmatched ([], [], in_api_only, in_pkg_only) => (reverse in_api_only, reverse in_pkg_only );
find_unmatched ([], r, in_api_only, in_pkg_only) => (reverse in_api_only, reverse in_pkg_only @ r);
find_unmatched ( r, [], in_api_only, in_pkg_only) => (reverse in_api_only @ r, reverse in_pkg_only );
end;
end;
#
fun check_named_type (_, tdt::ERRONEOUS_TYPE, _)
=>
{
if_debugging_say ("check_named_type(_, tdt::ERRONEOUS_TYPE, _): Just returning Void");
();
};
check_named_type (type_per_api, type_per_pkg, typerstore)
=>
{ name_per_api = sy::name (tj::name_of_type type_per_api);
#
if_debugging_say ("check_named_type/TOP name_per_api = " + name_per_api);
case type_per_api
#
tdt::SUM_TYPE
{
stamp => s,
kind => api_kind,
is_eqtype => REF equality_property,
arity,
...
}
=>
{ fun no_sumtype ()
=
complain'("type " + name_per_api + " must be a sumtype");
if_debugging_say ("check_named_type/SUM_TYPE name_per_api = " + name_per_api);
if (arity != tj::arity_of_type type_per_pkg)
#
complain' ( "type arity for "
+ name_per_api
+ " does not match specified arity"
);
else
# BUG: under certain circumstances (bug 1364),
# a tdt::SUM_TYPE type_per_pkg should not be unwrapped.
#
# However, it must be unwrapped if it is a tdt::SUM_TYPE
# created by instantiating a direct or indirect
# sumtype replication spec (see bug 1432).
#
# For direct sumtype replication {\em declarations },
# there is no problem because the replicated
# sumtype is a SUM_TYPE.
#
# The unwrapping of sumtype relicants should be
# performed in macro_expand, not here. XXX BUGGO FIXME
#
case (api_kind, /* tj::unwrap_definition_star */ type_per_pkg)
#
( tdt::SUMTYPE { index => api_index, family => { members, ... }, ... },
tdt::SUM_TYPE { arity => a', kind => pkg_kind, ... }
)
=>
case pkg_kind
#
tdt::SUMTYPE { index => pkg_index,
family => { members => members', ... },
...
}
=>
{ api_dcons = (vector::get (members , api_index)).valcons;
pkg_dcons = (vector::get (members', pkg_index)).valcons;
api_names = map .name api_dcons;
pkg_names = map .name pkg_dcons;
if *debugging
apply (\\ s = (if_debugging_say (sy::name s))) api_names;
if_debugging_say "******";
apply (\\ s = (if_debugging_say (sy::name s))) pkg_names;
fi;
case (find_unmatched_valcons (api_names, pkg_names))
#
([], []) => ();
(in_api_only, in_pkg_only)
=>
complain' (
cat (
list::cat
[ [ "sumtype ", name_per_api, " does not match api declaration"],
case in_api_only
[] => [];
_ => [ "\n constructors in api declaration only: ",
symbols_to_string in_api_only
];
esac,
case in_pkg_only
[] => [];
_ => [ "\n constructors in package declaration only: ",
symbols_to_string in_pkg_only
];
esac
]
)
);
esac;
};
_ => no_sumtype ();
esac;
(tdt::SUMTYPE _, _) => no_sumtype ();
(tdt::FORMAL, _)
=>
if (equality_property == tdt::e::YES
and
not (eq_types::is_equality_type type_per_pkg)
)
complain'("type " + name_per_api + " must be an equality type");
fi;
_ => { tyd::debug_print
debugging
( "type_per_api: ",
unparse_type::unparse_type symbolmapstack,
type_per_api
);
tyd::debug_print
debugging
( "type_per_pkg: ",
unparse_type::unparse_type symbolmapstack,
type_per_pkg
);
bug "check_type_naming 1";
};
esac;
fi;
};
tdt::NAMED_TYPE { typescheme => tdt::TYPESCHEME { body, arity }, strict, stamp, namepath }
=>
{
if_debugging_say ("check_named_type/tdt::SUM_TYPE/TOP name_per_api = " + name_per_api + " src/lib/compiler/front/typer/modules/api-match-g.pkg");
typescheme
=
tdt::TYPESCHEME
{ body => mj::translate_typoid typerstore body,
arity
};
if_debugging_say ("check_named_type/tdt::SUM_TYPE/AAA name_per_api = " + name_per_api + " src/lib/compiler/front/typer/modules/api-match-g.pkg");
type_per_api'
=
tdt::NAMED_TYPE
{
typescheme, # The only part we change.
strict,
stamp,
namepath
};
if_debugging_say ("check_named_type/tdt::SUM_TYPE/BBB name_per_api = " + name_per_api + " src/lib/compiler/front/typer/modules/api-match-g.pkg");
if (not (tj::type_equality (type_per_api', type_per_pkg)))
#
tyd::debug_print
debugging
( "type_per_api': ",
unparse_type::unparse_type symbolmapstack,
type_per_api'
);
tyd::debug_print
debugging
( "type_per_pkg: ",
unparse_type::unparse_type symbolmapstack,
type_per_pkg
);
complain'
( "type "
+ name_per_api
+ " does not match api declaration"
);
fi;
};
tdt::ERRONEOUS_TYPE => raise exception BAD_NAMING;
_ => bug "check_named_type 2";
esac;
};
end; # fun check_named_type
stipulate
# Two support functions local to check_sharing():
#
fun find_package_via_symbol_path
(
elements,
typerstore
)
(syp::SYMBOL_PATH spath)
:
( mld::Api,
mld::Typerstore_Entry
)
=
loop (spath, elements, typerstore)
where
fun loop ( [symbol], elements, typerstore)
=>
case (mj::get_api_element (elements, symbol))
mld::PACKAGE_IN_API { module_stamp, an_api, ... }
=>
{ if_debugging_say ("@@@find_package_via_symbol_path.1: " + sy::name symbol + ", " + ep::module_stamp_to_string module_stamp);
(an_api, tro::find_entry_by_module_stamp (typerstore, module_stamp));
};
_ => bug "loop_package 1b";
esac
except
mj::UNBOUND _ = bug "find_package_via_symbol_path 1c";
loop (symbol ! rest, elements, typerstore)
=>
case (mj::get_api_element (elements, symbol))
#
mld::PACKAGE_IN_API { an_api => mld::API { api_elements, ... }, module_stamp, ... }
=>
case (tro::find_entry_by_module_stamp (typerstore, module_stamp))
#
mld::PACKAGE_ENTRY { typerstore, ... }
=>
{ if_debugging_say ( "@@@find_package_via_symbol_path.2: "
+ sy::name symbol
+ ", "
+ ep::module_stamp_to_string module_stamp
);
loop (rest, api_elements, typerstore);
};
mld::ERRONEOUS_ENTRY
=>
(mld::ERRONEOUS_API, mld::ERRONEOUS_ENTRY);
_ => bug "find_package_via_symbol_path 2a";
esac;
_ => bug "find_package_via_symbol_path 2b";
esac
except
mj::UNBOUND _ = bug "find_package_via_symbol_path 2c";
loop _ => bug "find_package_via_symbol_path 3";
end; # fun loop
end; # where
#
fun find_type_via_symbol_path (elements, typerstore) (syp::SYMBOL_PATH spath)
:
tdt::Type
=
loop (spath, elements, typerstore)
where
fun loop ([symbol], elements, typerstore)
=>
case (mj::get_api_element (elements, symbol))
#
mld::TYPE_IN_API { module_stamp, ... }
=>
case (tro::find_entry_by_module_stamp (typerstore, module_stamp))
#
mld::TYPE_ENTRY type => type;
mld::ERRONEOUS_ENTRY => tdt::ERRONEOUS_TYPE;
_ => bug "find_type_via_symbol_path 1a";
esac;
_ => bug "find_type_via_symbol_path 1b";
esac
except
mj::UNBOUND _ = bug "find_type_via_symbol_path 1c";
loop (symbol ! rest, elements, typerstore)
=>
case (mj::get_api_element (elements, symbol))
mld::PACKAGE_IN_API { an_api => mld::API { api_elements, ... }, module_stamp, ... }
=>
case (tro::find_entry_by_module_stamp (typerstore, module_stamp))
#
mld::PACKAGE_ENTRY { typerstore, ... }
=>
loop (rest, api_elements, typerstore);
mld::ERRONEOUS_ENTRY => tdt::ERRONEOUS_TYPE;
_ => bug "find_type_via_symbol_path 2a";
esac;
_ => bug "find_type_via_symbol_path 2b";
esac
except
mj::UNBOUND _
=
bug ("find_type_via_symbol_path 2c:" + symbol::name symbol + syp::to_string (syp::SYMBOL_PATH spath));
loop _ => bug "find_type_via_symbol_path 3";
end;
end;
herein
# Check whether all sharing constraints are satisfied:
#
fun check_sharing ( an_api as mld::ERRONEOUS_API, typerstore)
=>
(); # Don't do anything if an error has occurred, resulting in an mld::ERRONEOUS_API
check_sharing (an_api as mld::API { api_elements, type_sharing, package_sharing, ... }, typerstore)
=>
{ fun errmsg sp x
=
syp::to_string x + " != " + syp::to_string sp;
#
fun eq_type (_, tdt::ERRONEOUS_TYPE) => TRUE;
eq_type (tdt::ERRONEOUS_TYPE, _) => TRUE;
eq_type (type1, type2)
=>
tj::type_equality (type1, type2);
end;
find_package_via_symbol_path
=
find_package_via_symbol_path
( api_elements,
typerstore
);
#
fun common_elements
(
mld::API api1,
mld::API api2
)
=>
{ elements1 = api1.api_elements;
elements2 = api2.api_elements;
#
fun elem_gt ((s1, _), (s2, _))
=
sy::symbol_gt (s1, s2);
elements1 = lms::sort_list elem_gt elements1;
elements2 = lms::sort_list elem_gt elements2;
intersect (elements1, elements2)
where
fun intersect (e1 as ((s1, spec1) ! rest1),
e2 as ((s2, spec2) ! rest2))
=>
if (sy::eq (s1, s2))
(s1, spec1, spec2) ! intersect (rest1, rest2);
else
if (sy::symbol_gt (s1, s2)) intersect (e1, rest2);
else intersect (rest1, e2);
fi;
fi;
intersect(_, _)
=>
NIL;
end; # fun intersect
end; # where
};
common_elements _
=>
bug "common_elements";
end; # fun common_elements
# Apply 'test' to all possible
# pairs of values from given
# list -- O(N**2) tests for
# length-N list:
#
fun apply_to_all_pairs test NIL
=>
();
apply_to_all_pairs test (a ! r)
=>
{ apply (\\ x = test (a, x)) r;
apply_to_all_pairs test r;
};
end;
#
fun compare_packages
( (p1, (an_api1, ent1)),
(p2, (an_api2, ent2))
)
=
case (ent1, ent2)
( mld::PACKAGE_ENTRY { stamp => s1, typerstore => dict1, ... },
mld::PACKAGE_ENTRY { stamp => s2, typerstore => dict2, ... }
)
=>
if (sta::same_stamp (s1, s2))
(); # shortcut!
else
if (mj::apis_equal (an_api1, an_api2))
if_debugging_say "@@@compare_packages: an_api1 == an_api2";
my { api_elements, ... }
=
case an_api1 mld::API api_record => api_record;
_ => bug "compare_packages: mld::API";
esac;
for' api_elements compare
where
fun compare (symbol, mld::TYPE_IN_API { module_stamp, ... } )
=>
{ type1 = unwrap_typecon_entry (tro::find_entry_by_module_stamp (dict1, module_stamp));
type2 = unwrap_typecon_entry (tro::find_entry_by_module_stamp (dict2, module_stamp));
if (not (eq_type (type1, type2)))
complain (
cat
[ "implied type sharing violation: ",
errmsg
(syp::extend (p1, symbol))
(syp::extend (p2, symbol))
]
);
fi;
};
compare (symbol, mld::PACKAGE_IN_API { module_stamp, an_api, ... } )
=>
{ ent1' = tro::find_entry_by_module_stamp (dict1, module_stamp);
ent2' = tro::find_entry_by_module_stamp (dict2, module_stamp);
compare_packages (
(syp::extend (p1, symbol), (an_api, ent1')),
(syp::extend (p2, symbol), (an_api, ent2'))
);
};
compare _ => ();
end; # fun compare
end; # where
else
if_debugging_say "@@@compare_packages: an_api1 != an_api2";
common_api_elements
=
common_elements (an_api1, an_api2);
for' common_api_elements
\\ ( symbol,
mld::TYPE_IN_API { module_stamp => v1, ... },
mld::TYPE_IN_API { module_stamp => v2, ... }
)
=>
{ type1 = unwrap_typecon_entry (tro::find_entry_by_module_stamp (dict1, v1));
type2 = unwrap_typecon_entry (tro::find_entry_by_module_stamp (dict2, v2));
if (not (eq_type (type1, type2)))
#
complain( cat [ "type sharing violation: ",
errmsg (syp::extend (p1, symbol))
(syp::extend (p2, symbol))
]
);
fi;
};
( symbol,
mld::PACKAGE_IN_API { module_stamp=>v1, an_api => an_api1', ... },
mld::PACKAGE_IN_API { module_stamp=>v2, an_api => an_api2', ... }
)
=>
{ str1 = tro::find_entry_by_module_stamp (dict1, v1);
str2 = tro::find_entry_by_module_stamp (dict2, v2);
compare_packages ( (syp::extend (p1, symbol), (an_api1', str1)),
(syp::extend (p2, symbol), (an_api2', str2))
);
};
_ => ();
end; # fn
fi;
fi;
(mld::ERRONEOUS_ENTRY, _) => (); # error upstream
(_, mld::ERRONEOUS_ENTRY) => (); # error upstream
_ => bug "compare_packages";
esac;
#
fun check_package paths
=
{ pathstrs
=
map (\\ p = (p, find_package_via_symbol_path p))
paths;
apply_to_all_pairs compare_packages pathstrs;
};
#
fun check_type' (first_path, rest)
=
{ find_type_via_symbol_path
=
find_type_via_symbol_path
(
api_elements,
typerstore
);
err_msg = errmsg first_path;
first = find_type_via_symbol_path
first_path;
apply check_path rest
where
fun check_path p
=
if (not (eq_type (first, find_type_via_symbol_path p)))
#
complain (cat [ "type sharing violation: ", err_msg p ] );
fi;
end;
};
#
fun check_type (sp ! rest) => check_type' (sp, rest);
check_type _ => bug "check_sharing: check_type";
end;
apply check_package package_sharing;
apply check_type type_sharing;
};
end; # fun check_sharing
end; # stipulate
# Matching: Go through the `elements' of the specified api,
# and construct a corresponding typechecked_package
# from typerstore found in the given package.
#
# The package's typerstore entries are found
# by using the stamppath in each of the given package api's
# elements to access the given package's typechecked_package
# = stored typerstore.
#
# Subpackages are processed recursively.
#
# Build the formal typechecked_package in parallel.
#
# Finally check sharing constraints.
# fun match_all_api_elements:
# ( List( sy::Symbol, Api_Element ),
# Typerstore,
# List( Module_Declaration ),
# List( ds::Declaration ),
# List( sxe::Symbolmapstack_Entry )
# )
# ->
# ( List( ds::Declaration ),
# List( sxe::Symbolmapstack_Entry ),
# Typerstore,
# List( Module_Declaration)
# )
#
# Given the elements and the typerstore
# of a constrained package and a constraining api,
# extend the typechecked_package (Typerstore)
# with the typechecked_package specified by the spec,
# extend the list of coercions (typechecked_package declarations)
# with a declaration which will evaluate to the
# new typechecked_package, and extend the thinning.
#
# We assume that if a match error occurs
# then the resulting thinning and the
# list of module_declarations
# will never be used -- they will not be
# well-formed in case of errors.
stipulate
# A private support function for
# fun match_all_api_elements:
#
fun match_def_package args
=
case args
( api_elements,
mld::A_PACKAGE { an_api => api_d, typechecked_package => typechecked_package_d, ... }, # Package from constraining api.
mld::A_PACKAGE { an_api => api_m, typechecked_package => typechecked_package_m, ... } # Package from constrained package.
)
=>
{ stamp_d = typechecked_package_d.stamp;
stamp_m = typechecked_package_m.stamp;
if (sta::same_stamp (stamp_d, stamp_m)) # eq_origin
TRUE;
else
match_def_package'
(
api_elements,
api_d, typechecked_package_d,
api_m, typechecked_package_m
);
fi;
};
_ => bug "match_def_package (2)";
esac
where
# Private support function for match_def_package():
#
fun match_def_package'
(
api_elements,
api_d, typechecked_package_d,
api_m, typechecked_package_m
)
=
{ # Function to drop from api element list all elements
# except for mld::TYPE_IN_API and mld::PACKAGE_IN_API:
#
drop_vals
=
list::filter
\\ (s, (mld::TYPE_IN_API _ | mld::PACKAGE_IN_API _ )) => TRUE;
_ => FALSE;
end ;
nonvalue_api_elements
=
drop_vals api_elements;
#
fun elem_gt ((s1, _), (s2, _))
=
sy::symbol_gt (s1, s2);
# Get the list of elements from an API.
# Each element is a (name, value) pair
# where the name is a symbol:
#
fun get_elements (mld::API { api_elements, ... }) => api_elements;
get_elements _ => bug "match_def_package': API (1)";
end;
# The api_d (constraining) api elements will be a list of (symbol, type_d) pairs.
# The api_m (constrained ) api elements will be a list of (symbol, type_m) pairs.
#
# From the pairs with matching symbols, create a list of triples
# (symbol, type_d, type_m)
#
common_dm_api_elements
=
if (mj::apis_equal (api_d, api_m))
#
api_elements
=
lms::sort_list
elem_gt
(drop_vals (get_elements api_d));
map (\\ (s, spec) = (s, spec, spec))
api_elements;
else
elements_d = lms::sort_list elem_gt (drop_vals (get_elements api_d));
elements_m = lms::sort_list elem_gt (drop_vals (get_elements api_m));
intersect (elements_d, elements_m)
where
fun intersect (list1 as ((symbol1, spec1) ! rest1),
list2 as ((symbol2, spec2) ! rest2)
)
=>
if (sy::eq (symbol1, symbol2))
(symbol1, spec1, spec2) ! intersect (rest1, rest2);
else
(sy::symbol_gt (symbol1, symbol2))
?? intersect (list1, rest2)
:: intersect (rest1, list2);
fi;
intersect(_, _) => NIL;
end; # fun intersect
end; # where
fi;
# Here we reduce the above list of triples to
# those it has in common with nonvalue_api_elements,
# and add in the type information from the latter,
# yielding a list of quadruples
# (symbol, type_a, type_d, type_m)
#
common_api_elements
=
intersect' (nonvalue_api_elements, common_dm_api_elements)
where
fun intersect' ( elements1 as ((symbol1, x) ! rest1),
elements2 as ((symbol2, y, z) ! rest2)
)
=>
if (sy::eq (symbol1, symbol2))
(symbol1, x, y, z) ! intersect' (rest1, rest2);
else
sy::symbol_gt (symbol1, symbol2)
?? intersect' (elements1, rest2) # Discard symbol2
:: intersect' (rest1, elements2); # Discard symbol1
fi;
intersect' (_, _)
=>
NIL;
end; # fun intersect'
end; # where
loop common_api_elements
where
fun loop NIL
=>
TRUE;
loop ((symbol, api_element, spec_d, spec_m) ! rest)
=>
case api_element
#
mld::TYPE_IN_API _
=>
{ fun unwrap_typecon (mld::TYPE_IN_API x) => x;
unwrap_typecon _ => bug "thin_package': unTypespec";
end;
modstamp_d = (unwrap_typecon spec_d).module_stamp;
modstamp_m = (unwrap_typecon spec_m).module_stamp;
dictionary_d = typechecked_package_d.typerstore;
dictionary_m = typechecked_package_m.typerstore;
tyc_d = unwrap_typecon_entry (tro::find_entry_by_module_stamp (dictionary_d, modstamp_d));
tyc_m = unwrap_typecon_entry (tro::find_entry_by_module_stamp (dictionary_m, modstamp_m));
tj::type_equality (tyc_d, tyc_m)
and
loop rest; # Added recursive call because a 'loop' fn which didn't loop seemed odd. -- 2009-07-18 CrT
};
mld::PACKAGE_IN_API { an_api => mld::API { api_elements, ... }, ... }
=>
{ fun unwrap_pkg_spec (mld::PACKAGE_IN_API x) => x;
unwrap_pkg_spec _ => bug "thin_package': unwrap_pkg_spec";
end;
my { module_stamp => modstamp_d, an_api => api_d', ... } = unwrap_pkg_spec spec_d;
my { module_stamp => modstamp_m, an_api => api_m', ... } = unwrap_pkg_spec spec_m;
dictionary_d = typechecked_package_d.typerstore;
dictionary_m = typechecked_package_m.typerstore;
fun unwrap_pkg_entry (mld::PACKAGE_ENTRY x) => x;
unwrap_pkg_entry _ => bug "thin_package': unwrap_pkg_entry";
end;
typechecked_package_d' = unwrap_pkg_entry (tro::find_entry_by_module_stamp (dictionary_d, modstamp_d));
typechecked_package_m' = unwrap_pkg_entry (tro::find_entry_by_module_stamp (dictionary_m, modstamp_m));
# Call ourself recursively
# to process subpackage:
#
match_def_package'
(
api_elements,
api_d', typechecked_package_d',
api_m', typechecked_package_m'
)
and
loop rest; # Added recursive call because a 'loop' fn which didn't loop seemed odd. -- 2009-07-18 CrT
};
_ => bug "thin_package'";
esac;
end; # fun loop
end; # where
}; # fun match_def_package'
end; # where
herein
#
fun match_all_api_elements
( [], # Input list exhausted, time to construct final result.
typerstore,
module_declarations,
abstract_declarations,
symbolmapstack_entries,
match_succeeded
)
=>
( reverse abstract_declarations,
reverse symbolmapstack_entries,
typerstore,
reverse module_declarations,
match_succeeded
);
match_all_api_elements
( (api_element_symbol, api_element) ! remaining_api_elements, # Input list, starts as constraining_api_elements.
typerstore, # Dictionary accumulating seen generics, also mld::TYPE_ENTRY, also thinned_package from thin_package'.
module_declarations, # List accumulating mld::Module_Declaration stuff: mld::TYPE_DECLARATION, PACKAGE_DECLARATION, GENERIC_DECLARATION (...?)
abstract_declarations, # List accumulating deep syntax: ds::VALUE_DECLARATIONS[ PLAIN_VARIABLE | NAMED_VALUE ]
symbolmapstack_entries, # List accumulating symbol table entries: sxe::NAMED_CONSTRUCTOR, NAMED_VARRIABLE, NAMED_PACKAGE, NAMED_GENERIC.
match_succeeded # Starts TRUE, set FALSE at first api/pkg mismatch detected.
)
=>
{ if_debugging_say "match_all_api_elements/TOP";
# Issue an error message,
# remember that the api match failed,
# process rest of api elements anyhow:
#
fun complain_and_loop (kind_op: Null_Or( String ))
=
{ typerstore'
=
case (mj::get_api_element_variable api_element)
#
THE v => tro::set (typerstore, v, mld::ERRONEOUS_ENTRY);
NULL => typerstore;
esac;
# Synthesize a new error naming
# to remove improper error
# messages on inline_info (ZHONG)
symbolmapstack_entries'
=
case api_element
#
mld::TYPE_IN_API _ => symbolmapstack_entries;
#
mld::VALCON_IN_API { slot=>NULL, ... } => symbolmapstack_entries;
_ => sxe::NAMED_CONSTRUCTOR variables_and_constructors::bogus_exception ! symbolmapstack_entries;
esac;
case kind_op
#
NULL => ();
THE kind => { complain("Sealed package lacks api-required element: " + kind + " " + sy::name api_element_symbol);
# Added 2011-05-30 CrT because above alone is often totally mysterious
# in the presence of large nested generic-package invocations:
# tyd::debug_print (REF TRUE) ("Constrained pkg name:", unparse_pkg_name, constrained_pkg ); # Unhelpful; prints "?<empty spath>", or "?back_patch" or such.
tyd::debug_print (REF TRUE) ("Constrained pkg:", unparse_pkg, constrained_pkg );
tyd::debug_print (REF TRUE) ("Constraining api:", unparse_api, constraining_api);
};
esac;
# Match has failed, but process rest of API
# to maybe generate additional useful diagnostics
# for user:
#
match_all_api_elements
(
remaining_api_elements,
typerstore',
module_declarations,
abstract_declarations,
symbolmapstack_entries',
FALSE # Remember that API match failed.
);
};
#
fun type_in_matched (kind, type)
=
(mj::translate_typoid typerstore type)
except
tro::UNBOUND
=
{ tyd::debug_print debugging (kind, unparse_type::unparse_typoid symbolmapstack, type);
raise exception tro::UNBOUND;
};
#
fun type_in_original (kind, type)
=
(mj::translate_typoid package_typerstore type)
except
tro::UNBOUND
=
{ tyd::debug_print debugging (kind, unparse_type::unparse_typoid symbolmapstack, type);
raise exception tro::UNBOUND;
};
case api_element
#
mld::TYPE_IN_API { type => type_per_api, module_stamp, is_a_replica, scope }
=>
{ if_debugging_say ( string::cat [ "match_all_api_elements mld::TYPE_IN_API/TOP: ",
sy::name api_element_symbol, ", ",
sta::to_string module_stamp ] );
my (type_per_pkg, pkg_typechecked_package_variable)
=
mj::get_type (pkg_api_elements, package_typerstore, api_element_symbol)
except
tro::UNBOUND
=
{ tyd::debug_print
debugging
( "package_typerstore: ",
(\\ pps = \\ ee = unparse_package_language::unparse_typerstore pps (ee, symbolmapstack, 6)),
package_typerstore
);
raise exception tro::UNBOUND;
};
if_debugging_say ("--match_all_api_elements mld::TYPE_IN_API - pkg_typecheck_package_variable: " +
sta::to_string pkg_typechecked_package_variable);
# ** DAVE: please check the following ! XXX BUGGO FIXME **
tyc_module_expression
=
case rpath
#
[] => mld::CONSTANT_TYPE type_per_pkg;
_ => mld::TYPEVAR_TYPE (reverse (pkg_typechecked_package_variable ! rpath));
esac;
if_debugging_say "--match_all_api_elements mld::TYPE_IN_API calling check_named_type";
check_named_type (type_per_api, type_per_pkg, typerstore);
if_debugging_say "--match_all_api_elements mld::TYPE_IN_API calling tro::set";
typerstore'
=
tro::set
(
typerstore,
module_stamp,
mld::TYPE_ENTRY type_per_pkg
);
module_declarations'
=
mld::TYPE_DECLARATION (
module_stamp,
tyc_module_expression
)
!
module_declarations;
if_debugging_say "match_all_api_elements mld::TYPE_IN_API/BOT check_named_type";
match_all_api_elements (
#
remaining_api_elements,
typerstore',
module_declarations',
abstract_declarations,
symbolmapstack_entries,
match_succeeded
);
}
except
mj::UNBOUND symbol
=>
complain_and_loop (THE "type");
BAD_NAMING
=>
complain_and_loop NULL;
tro::UNBOUND
=>
{ if_debugging_say ("match_all_api_elements (mld::TYPE_IN_API) tro::UNBOUND raised for: " + sy::name api_element_symbol);
raise exception tro::UNBOUND;
};
end;
mld::PACKAGE_IN_API
{ an_api => this_spec_api as mld::API api_record,
module_stamp,
definition,
...
}
=>
{ this_elements = api_record.api_elements;
if_debugging_say (
string::cat [
"--match_all_api_elements mld::PACKAGE_IN_API: ",
sy::name api_element_symbol,
", ",
sta::to_string module_stamp
]
);
my (pkg_package, pkg_package_module_stamp)
=
mj::get_package
(
pkg_api_elements,
package_typerstore,
api_element_symbol,
constrained_pkg_varhome,
constrained_pkg_inline_info
);
# Verify spec definition, if any
# match_def_package now does the proper deep, component-wise
# comparison of api_package and pkg_package when their stamps
# don't agree, but the error message printed
# when definition spec is not matched leaves something
# to be desired XXX BUGGO FIXME
#
case definition
#
NULL => ();
THE (package_definition, _)
=>
{ api_package
=
mj::package_definition_to_package (
package_definition,
typerstore
);
if (not (match_def_package (this_elements, api_package, pkg_package)))
case package_definition
mld::VARIABLE_PACKAGE_DEFINITION (an_api, stamppath)
=>
if_debugging_say ( "spec def VAR: "
+ ep::stamppath_to_string stamppath
+ "\n"
);
mld::CONSTANT_PACKAGE_DEFINITION _
=>
if_debugging_say ("spec def CONST\n");
esac;
if_debugging_show_package("api_package: ", api_package);
if_debugging_show_package("pkg_package: ", pkg_package);
complain ( "package def spec for "
+ sy::name api_element_symbol
+ " not matched"
);
fi;
};
esac;
rpath' = pkg_package_module_stamp ! rpath;
inverse_path' = ip::extend (inverse_path, api_element_symbol);
# Call ourself recursively
# to process subpackage:
#
my ( thinned_declaration,
thinned_package,
package_expression
)
=
thin_package' (
pkg_package,
this_spec_api,
api_element_symbol,
debruijn_depth,
typerstore,
rpath',
inverse_path',
symbolmapstack,
source_code_region,
per_compile_stuff
);
typerstore'
=
{ typechecked_package
=
case thinned_package
mld::A_PACKAGE { typechecked_package, ... } => typechecked_package;
_ => mld::bogus_typechecked_package;
esac;
tro::set (typerstore, module_stamp, mld::PACKAGE_ENTRY typechecked_package);
};
module_declarations'
=
mld::PACKAGE_DECLARATION (module_stamp, package_expression, api_element_symbol)
!
module_declarations ;
abstract_declarations'
=
thinned_declaration ! abstract_declarations;
symbolmapstack_entries'
=
(sxe::NAMED_PACKAGE thinned_package)
!
symbolmapstack_entries;
match_all_api_elements
(
remaining_api_elements,
typerstore',
module_declarations',
abstract_declarations',
symbolmapstack_entries',
match_succeeded
);
}
except mj::UNBOUND symbol
=
complain_and_loop (THE "package");
mld::GENERIC_IN_API { a_generic_api => spec_api, module_stamp, ... }
=>
( { if_debugging_say (
string::cat [
"--match_all_api_elements mld::GENERIC_IN_API: ",
sy::name api_element_symbol,
", ",
sta::to_string module_stamp
]
);
my (pkg_g, generic_module_stamp)
=
mj::get_generic (
pkg_api_elements,
package_typerstore,
api_element_symbol,
constrained_pkg_varhome,
constrained_pkg_inline_info
);
expression'
=
mld::VARIABLE_GENERIC (reverse (generic_module_stamp ! rpath));
inverse_path'
=
ip::extend (inverse_path, api_element_symbol);
my (thinned_declaration, thinned_g, generic_expression)
=
match_generic1
(
spec_api,
pkg_g,
api_element_symbol,
debruijn_depth,
typerstore,
expression',
inverse_path',
symbolmapstack,
source_code_region,
per_compile_stuff
);
typerstore'
=
{ typechecked_generic
=
case thinned_g
mld::GENERIC { typechecked_generic, ... } => typechecked_generic;
_ => mld::bogus_typechecked_generic;
esac;
tro::set (
typerstore,
module_stamp,
mld::GENERIC_ENTRY typechecked_generic
);
};
module_declarations'
=
mld::GENERIC_DECLARATION (module_stamp, generic_expression)
!
module_declarations;
abstract_declarations'
=
thinned_declaration ! abstract_declarations;
symbolmapstack_entries'
=
(sxe::NAMED_GENERIC thinned_g) ! symbolmapstack_entries;
match_all_api_elements
(
remaining_api_elements,
typerstore',
module_declarations',
abstract_declarations',
symbolmapstack_entries',
match_succeeded
);
}
except mj::UNBOUND symbol
=
complain_and_loop (THE "generic package")
);
mld::VALUE_IN_API { typoid => type_per_api, ... }
=>
case (mj::get_api_element (pkg_api_elements, api_element_symbol))
#
mld::VALUE_IN_API { typoid => type_per_pkg, slot => slot_per_pkg }
=>
{ type_per_api = type_in_matched ("@@@type_per_api (my/val)", type_per_api);
type_per_pkg = type_in_original ("@@@type_per_pkg (my/val)", type_per_pkg);
varhome = vh::select_varhome (constrained_pkg_varhome, slot_per_pkg);
inlining_data = id::select (constrained_pkg_inline_info, slot_per_pkg);
(unify_typoids { type_per_api, type_per_pkg, inlining_data, name => api_element_symbol })
->
(types, generalized_typevars);
path = syp::SYMBOL_PATH [api_element_symbol];
pkg_var = vac::PLAIN_VARIABLE
{
path,
vartypoid_ref => REF type_per_pkg,
#
varhome,
inlining_data
};
my (abstract_declarations', new_var)
=
case ( tj::head_reduce_typoid type_per_pkg,
tj::head_reduce_typoid type_per_api
)
((tdt::TYPESCHEME_TYPOID _, _) | (_, tdt::TYPESCHEME_TYPOID _))
=>
{ varhome = vh::named_varhome (api_element_symbol, make_var);
#
api_var = vac::PLAIN_VARIABLE
{
path,
vartypoid_ref => REF type_per_api,
inlining_data,
varhome
};
if (*debugging and ((list::length generalized_typevars) > 0))
printf "api-match-g.pkg: Creating ds::VALUE_NAMING node with length(generalized_typevars) d=%d (I)\n" (list::length generalized_typevars);
apply unparse_typevar_ref generalized_typevars
where
unparse_typevar_ref
=
unparse_type::unparse_typevar_ref
symbolmapstack;
#
fun if_debugging_unparse_typevar_ref (msg, typevar_ref)
=
if *debugging # Without this 'if' (and the matching one in unify_typoids), compiling the compiler takes 5X as long! :-)
typer_debugging::with_internals
(\\ () = tyd::debug_print debugging (msg, unparse_typevar_ref, typevar_ref));
fi;
#
fun unparse_typevar_ref typevar_ref
=
if_debugging_unparse_typevar_ref ("", typevar_ref);
end;
printf "\n";
fi;
named_value
=
ds::VALUE_NAMING { pattern => ds::VARIABLE_IN_PATTERN api_var,
expression => ds::VARIABLE_IN_EXPRESSION { var => REF pkg_var, typescheme_args => types },
raw_typevars => REF [],
generalized_typevars
};
( (ds::VALUE_DECLARATIONS [named_value]) ! abstract_declarations,
api_var
);
};
_ => (abstract_declarations, pkg_var);
esac;
symbolmapstack_entries'
=
(sxe::NAMED_VARIABLE new_var) ! symbolmapstack_entries;
match_all_api_elements
(
remaining_api_elements,
typerstore,
module_declarations,
abstract_declarations',
symbolmapstack_entries',
match_succeeded
);
};
mld::VALCON_IN_API
{
slot,
sumtype => tdt::VALCON { typoid => type_per_pkg,
name,
is_constant,
form,
signature,
is_lazy
}
}
=>
{ type_per_api = type_in_matched ("@@@type_per_api (my/con)", type_per_api );
type_per_pkg = type_in_original ("@@@type_per_pkg (my/con)", type_per_pkg );
(unify_typoids { type_per_api, type_per_pkg, inlining_data => id::NIL, name })
->
(types, generalized_typevars);
new_form
=
case slot
THE s => exception_representation (form, vh::select_varhome (constrained_pkg_varhome, s));
NULL => form;
esac;
my (abstract_declarations', symbolmapstack_entries')
=
{ valcon = tdt::VALCON
{
typoid => type_per_pkg,
form => new_form,
name,
is_constant,
signature,
is_lazy
};
varhome = vh::named_varhome (name, make_var);
api_var = vac::PLAIN_VARIABLE
{
path => syp::SYMBOL_PATH [name],
varhome,
inlining_data => id::NIL,
vartypoid_ref => REF type_per_api
};
if (*debugging and ((list::length generalized_typevars) > 0))
printf "api-match-g.pkg: Creating ds::VALUE_NAMING node with length(generalized_typevars) d=%d (II)\n" (list::length generalized_typevars);
fi;
named_value = ds::VALUE_NAMING
{
pattern => ds::VARIABLE_IN_PATTERN api_var,
expression => ds::VALCON_IN_EXPRESSION { valcon, typescheme_args => types },
raw_typevars => REF [],
generalized_typevars
};
( (ds::VALUE_DECLARATIONS [named_value]) ! abstract_declarations,
(sxe::NAMED_VARIABLE api_var) ! symbolmapstack_entries
);
};
match_all_api_elements
(
remaining_api_elements,
typerstore,
module_declarations,
abstract_declarations',
symbolmapstack_entries',
match_succeeded
);
};
_ => bug "match v elem.1";
esac
except mj::UNBOUND name
=
complain_and_loop (THE "value");
mld::VALCON_IN_API
{
sumtype => tdt::VALCON
{
name,
typoid => type_per_api,
is_lazy,
form => form_per_api,
...
},
...
}
=>
case (mj::get_api_element (pkg_api_elements, name))
#
mld::VALCON_IN_API
{
sumtype => tdt::VALCON
{
typoid => type_per_pkg,
form => form_per_pkg,
is_constant,
signature,
...
},
slot
}
=>
if ( vh::is_exception form_per_api
==
vh::is_exception form_per_pkg
)
type_per_api = type_in_matched ("@@@type_per_api (con/con)", type_per_api);
type_per_pkg = type_in_original("@@@type_per_pkg (con/con)", type_per_pkg);
unify_typoids { type_per_api, type_per_pkg, inlining_data => id::NIL, name };
symbolmapstack_entries'
=
case slot
#
NULL => symbolmapstack_entries;
THE s
=>
{ varhome = vh::select_varhome (constrained_pkg_varhome, s);
new_form = exception_representation (form_per_pkg, varhome);
con = tdt::VALCON
{
typoid => type_per_pkg,
form => new_form,
name,
is_constant,
is_lazy,
signature
};
(sxe::NAMED_CONSTRUCTOR con) ! symbolmapstack_entries;
};
esac;
match_all_api_elements
(
remaining_api_elements,
typerstore,
module_declarations,
abstract_declarations,
symbolmapstack_entries',
match_succeeded
);
else
raise exception mj::UNBOUND name;
fi;
mld::VALUE_IN_API _
=>
if (vh::is_exception form_per_api) complain_and_loop (THE "exception" );
else complain_and_loop (THE "constructor");
fi;
_ => bug "match v elem.2";
esac
except
mj::UNBOUND name
=
if (vh::is_exception form_per_api) complain_and_loop (THE "exception" );
else complain_and_loop (THE "constructor");
fi;
_ => bug "match_all_api_elements";
esac;
};
end; # fun match_all_api_elements
end; # Stipulate.
#
fun match_pkg_to_api typerstore
=
{ if_debugging_say "match_pkg_to_api/TOP";
my ( abstract_declarations, # Goes into thinned_declarations.
symbolmapstack_entries, # Contributes to thinned_declarations, also inlining_data in thinned_package.
typerstore, # Goes into thinned_package.
module_declarations, # Goes into coerced_package_expression.
match_succeeded
)
=
match_all_api_elements
(
constraining_api_elements,
typerstore, #
[], # module_declarations
[], # abstract_declarations
[], # symbolmapstack_entries
TRUE # match_succeeded
)
except
tro::UNBOUND
=
{ if_debugging_say "match_pkg_to_api 1: UNBOUND raised.";
raise exception tro::UNBOUND;
};
if match_succeeded
typerstore
=
tro::mark (make_fresh_stamp, typerstore);
if_debugging_say "--match_pkg_to_api: elements matched successfully";
check_sharing (constraining_api, typerstore)
except
tro::UNBOUND
=
{ if_debugging_say "@@@match_pkg_to_api 3";
raise exception tro::UNBOUND;
};
if_debugging_say "--match_pkg_to_api: sharing checked";
thinned_package
=
mld::A_PACKAGE {
an_api => constraining_api,
varhome => vh::make_varhome make_var,
inlining_data => id::LIST (map mj::extract_inlining_data symbolmapstack_entries),
typechecked_package
=>
{ stamp => pkg_stamp,
property_list => property_list::make_property_list (),
stub => NULL,
typerstore,
inverse_path
}
};
thinned_declarations
=
ds::PACKAGE_DECLARATIONS [
ds::NAMED_PACKAGE {
name_symbol => package_name,
a_package => thinned_package,
definition
=>
ds::PACKAGE_LET
{
declaration => ds::SEQUENTIAL_DECLARATIONS abstract_declarations,
expression => ds::PACKAGE_DEFINITION symbolmapstack_entries
}
}
];
coerced_package_expression
=
mld::PACKAGE { stamp => mld::GET_STAMP (mld::VARIABLE_PACKAGE (reverse rpath)),
module_declaration => mld::SEQUENTIAL_DECLARATIONS module_declarations
};
if_debugging_say "match_pkg_to_api/BOT";
( thinned_declarations,
thinned_package,
coerced_package_expression
);
else # !match_succeeded
( ds::SEQUENTIAL_DECLARATIONS [],
mld::ERRONEOUS_PACKAGE,
mld::CONSTANT_PACKAGE (mld::bogus_typechecked_package)
);
fi;
}; # fun match_pkg_to_api
# We should not do such short-cut matching because we need to
# recalculuate the Typepath information for generic
# components.
#
# But completely turning this off is a bit too expensive, so
# we add a contains_generic in the api to indicate whether it
# contains generic components.
#
if ( (sta::same_stamp (constraining_api_stamp, pkg_api_stamp))
and constraining_api_is_closed
and (not constraining_api_contains_generic)
)
# Short-cut matching:
#
( ds::SEQUENTIAL_DECLARATIONS [],
constrained_pkg,
mld::VARIABLE_PACKAGE (reverse rpath)
);
else
match_pkg_to_api
(
constraining_api_is_closed
?? tro::empty
:: match_typerstore
);
fi;
};
thin_package' _
=>
( ds::SEQUENTIAL_DECLARATIONS [],
mld::ERRONEOUS_PACKAGE,
bogus_package_expression
);
end # fun thin_package'
########################################################################################
#
# fun thin_package
#
# This gets invoked (only) from two points in
#
# src/lib/compiler/front/typer/main/type-package-language-g.pkg #
also
fun thin_package
{
constrained_package: mld::Package,
constraining_api: mld::Api,
package_expression: mld::Package_Expression,
module_stamp_or_null: Null_Or(sta::Stamp),
debruijn_depth: di::Debruijn_Depth,
typerstore: mld::Typerstore,
inverse_path: ip::Inverse_Path,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff => per_compile_stuff as { make_fresh_stamp, ... }: trj::Per_Compile_Stuff
}
:
{ result_declaration: ds::Declaration, # Package type info for the resulting deep syntax tree. (ds::PACKAGE_LET.declaration)
result_package: mld::Package, # Package code info for the resulting deep syntax tree. (ds::PACKAGE_LET.expression )
coerced_package_expression: mld::Package_Expression # This winds up in module_declarations (i.e., internal to typechecker).
}
=
{ if_debugging_say "thin_package/TOP";
uncoerced_module_stamp
=
case module_stamp_or_null
#
THE x => x;
NULL => make_fresh_stamp ();
esac;
my (result_declaration, result_package, coercion_expression)
=
thin_package' ( constrained_package,
constraining_api,
anonymous_package_symbol, # Added.
debruijn_depth,
typerstore,
[ uncoerced_module_stamp ], # Added.
inverse_path,
symbolmapstack,
source_code_region,
per_compile_stuff
);
coerced_package_expression
=
mld::COERCED_PACKAGE
{
boundvar => uncoerced_module_stamp,
raw => package_expression,
coercion => coercion_expression
};
# result_expression = mld::PACKAGE_LET { declaration => mld::PACKAGE_DECLARATION (uncoerced_module_stamp, package_expression), expression };
# result_expression = mld::APPLY (mld::LAMBDA { parameter=uncoerced_module_stamp, body=expression }, package_expression) ;
if_debugging_say "thin_package/BOT";
{ result_declaration, # ds::Declaration,
result_package, # mld::Generic,
coerced_package_expression # mld::Package_Expression -- coerced version of original package_expression.
};
}
except tro::UNBOUND
=
{ if_debugging_say "thin_package: UNBOUND was thrown. src/lib/compiler/front/typer/modules/api-match-g.pkg";
raise exception tro::UNBOUND;
}
##########################################################################
#
# Matching a generic package against a generic api:
#
#
# Arguments: funsig F (fsigParVariable: fsigParSig) = fsigBodySig
# generic package F (genericParVariable: genericParSig) : genericBodySig = bodyExpression
#
# Result: generic package F (genericParVariable: genericParSig) : genericBodySig = resultBodyExpression
#
##########################################################################
also
fun match_generic1
(
spec_api
as
mld::GENERIC_API
{ parameter_api => fsig_param_sig,
parameter_variable => fsig_param_variable,
parameter_symbol,
body_api => fsig_body_sig,
...
}
:
mld::Generic_Api,
a_generic
as
mld::GENERIC { typechecked_generic,
...
}
:
mld::Generic,
generic_name: sy::Symbol,
debruijn_depth: di::Debruijn_Depth,
typerstore: mld::Typerstore,
uncoerced_generic: mld::Generic_Expression,
inverse_path: ip::Inverse_Path,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff
as
{ make_fresh_stamp,
issue_highcode_codetemp => make_var,
...
}
: trj::Per_Compile_Stuff
)
:
( ds::Declaration,
mld::Generic,
mld::Generic_Expression
)
=>
( { # ** the typechecked_package var for the source generic "uncoerced_generic"
uncoerced = make_fresh_stamp();
src_generic_expression
=
mld::VARIABLE_GENERIC [uncoerced];
generic_api_parameter_typechecked_package_symbol
=
case parameter_symbol
THE x => x;
NULL => generic_api_parameter_typechecked_package_symbol;
esac;
# ** parameter api instantiation **
my { typechecked_package => fsig_par_typechecked_package,
typepaths => param_tps
}
=
gxs::do_generic_parameter_api {
an_api => fsig_param_sig,
inverse_path => ip::INVERSE_PATH [generic_api_parameter_typechecked_package_symbol],
typerstore,
debruijn_depth,
source_code_region,
per_compile_stuff
};
debruijn_depth' = di::next debruijn_depth;
fsig_par_inst
=
{ fsig_par_varhome = vh::make_varhome make_var;
#
mld::A_PACKAGE { an_api => fsig_param_sig,
typechecked_package => fsig_par_typechecked_package,
varhome => fsig_par_varhome,
inlining_data => id::NIL
};
};
# ** applying aGeneric to the fsigParInst package **
param_id = fsig_param_variable; # make_fresh_stamp()
my { result_declaration => result_declaration1,
result_package => result_package1,
result_expression => result_expression1
}
=
{ param_expression
=
mld::VARIABLE_PACKAGE [param_id];
apply_generic {
a_generic,
generic_expression => src_generic_expression,
arg_package => fsig_par_inst,
arg_expression => param_expression,
debruijn_depth => debruijn_depth',
module_stamp_or_null => NULL,
stamppath_context => epc::init_context /* ? ZHONG */,
inverse_path => ip::empty,
symbolmapstack,
source_code_region,
per_compile_stuff
};
};
# Matching the result package against the body api
fsig_body_sig_dictionary
=
tro::set (
typerstore,
fsig_param_variable,
mld::PACKAGE_ENTRY fsig_par_typechecked_package
);
my { result_declaration => result_declaration2,
result_package => result_package2,
coerced_package_expression => result_expression2
}
=
{ rp = ip::INVERSE_PATH [ sy::make_package_symbol "<GenericResult>" ];
thin_package { constraining_api => fsig_body_sig,
constrained_package => result_package1,
package_expression => result_expression1,
module_stamp_or_null => NULL,
debruijn_depth => debruijn_depth',
typerstore => fsig_body_sig_dictionary,
inverse_path => rp,
symbolmapstack,
source_code_region,
per_compile_stuff
};
};
# Construct the Typepath for the resulting generic:
#
result_tps
=
case result_package2
mld::A_PACKAGE { an_api, typechecked_package, ... }
=>
gxs::get_packages_typepaths
{
typerstore => fsig_body_sig_dictionary,
an_api,
typechecked_package,
per_compile_stuff
};
_ => [];
esac;
# Construct the resulting coerced generic:
#
result_generic
=
{ result_expression3
=
mld::PACKAGE_LET
{
declaration
=>
mld::GENERIC_DECLARATION (
uncoerced,
mld::CONSTANT_GENERIC typechecked_generic
),
expression
=>
result_expression2
};
result_closure
=
mld::GENERIC_CLOSURE {
parameter_module_stamp => param_id,
body_package_expression => result_expression3,
typerstore
};
tps = tdt::TYPEPATH_GENERIC (param_tps, result_tps);
result_typechecked_package
=
{ stamp => typechecked_generic.stamp, # ** DAVE ? XXX BUGGO FIXME **
generic_closure => result_closure,
typepath => THE tps,
property_list => property_list::make_property_list (),
stub => NULL,
inverse_path
};
mld::GENERIC { a_generic_api => spec_api,
typechecked_generic => result_typechecked_package,
varhome => vh::make_varhome make_var,
inlining_data => id::NIL
};
};
# The resulting generic deep_syntax_tree
#
fdec = { body_abs
=
ds::PACKAGE_LET
{
declaration => ds::SEQUENTIAL_DECLARATIONS [ result_declaration1, result_declaration2 ],
expression => ds::PACKAGE_BY_NAME result_package2
};
generic_expression
=
ds::GENERIC_DEFINITION {
parameter => fsig_par_inst,
parameter_types => param_tps,
definition => body_abs
};
ds::GENERIC_DECLARATIONS [
ds::NAMED_GENERIC {
name_symbol => anonymous_generic_symbol,
a_generic => result_generic,
definition => generic_expression
}
];
};
# ** the generic typechecked_package expression **
generic_expression
=
mld::LET_GENERIC (
mld::GENERIC_DECLARATION (uncoerced, uncoerced_generic),
mld::LAMBDA_TP {
parameter => param_id,
body => result_expression2,
an_api => spec_api
}
);
(fdec, result_generic, generic_expression);
}
except
MATCH
=
( ds::SEQUENTIAL_DECLARATIONS [],
mld::ERRONEOUS_GENERIC,
bogus_generic_expression
)
);
# This is intended to handle only the two left-hand side
# occurrences of PACKAGE { ... } above, and is very crude.
# It should be replaced by case-expressions on the results of
# match etc. XXX BUGGO FIXME
match_generic1 _
=>
(ds::SEQUENTIAL_DECLARATIONS [], mld::ERRONEOUS_GENERIC, bogus_generic_expression);
end # fun match_generic1
####################################################################################
#
# my match_generic
#
####################################################################################
also
fun match_generic
{
an_api: mld::Generic_Api,
a_generic: mld::Generic,
generic_expression: mld::Generic_Expression,
debruijn_depth: di::Debruijn_Depth,
typerstore: mld::Typerstore,
inverse_path: ip::Inverse_Path,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff: trj::Per_Compile_Stuff
}
:
{ result_declaration: ds::Declaration,
result_generic: mld::Generic,
result_expression: mld::Generic_Expression
}
=
{ if_debugging_say "match_generic/TOP";
my (result_declaration, result_generic, result_expression)
=
match_generic1 (
an_api,
a_generic,
anonymous_generic_symbol,
debruijn_depth,
typerstore,
generic_expression,
inverse_path,
symbolmapstack,
source_code_region,
per_compile_stuff
);
if_debugging_say "match_generic/BOT";
{ result_declaration,
result_generic,
result_expression
};
}
except tro::UNBOUND
=
{ if_debugging_say "@@@matchGeneric";
raise exception tro::UNBOUND;
}
##########################################################################
#
# Packing a package against a api.
#
##########################################################################
also
fun cast_package'
(
# Constrained package:
#
mld::A_PACKAGE { varhome => constrained_package_varhome,
typechecked_package => { typerstore => constrained_package_typerstore, ... },
inlining_data => constrained_package_inlining_data,
...
}
:
mld::Package,
constraining_api
as
mld::API { api_elements, ... }
:
mld::Api,
result_typechecked_package
as
{ typerstore => result_typerstore, ... }
:
mld::Typechecked_Package,
abstract_types: tj::Typeset,
package_name: sy::Symbol,
depth: Int,
typerstore: mld::Typerstore,
inverse_path: ip::Inverse_Path,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff
as
{ issue_highcode_codetemp=>make_var, error_fn, ... }
:
trj::Per_Compile_Stuff
)
:
( ds::Declaration,
mld::Package
)
=>
{ fun type_in_result (kind, type)
=
(mj::translate_typoid
result_typerstore
type
)
except
tro::UNBOUND
=
{ tyd::debug_print debugging (kind, unparse_type::unparse_typoid symbolmapstack, type);
raise exception tro::UNBOUND;
};
#
fun type_in_source (kind, type)
=
(mj::translate_typoid
constrained_package_typerstore
type
)
except
tro::UNBOUND
=
{ tyd::debug_print debugging (kind, unparse_type::unparse_typoid symbolmapstack, type);
raise exception tro::UNBOUND;
};
#
fun cast_api_elements ([], typerstore, declarations, symbolmapstack_entries)
=>
( reverse declarations,
reverse symbolmapstack_entries
);
cast_api_elements
( (symbol, api_element) ! remaining_api_elements,
typerstore,
declarations,
symbolmapstack_entries
)
=>
{ if_debugging_say "cast_api_elements/TOP";
case api_element
#
mld::PACKAGE_IN_API
{
an_api => this_spec_api,
module_stamp,
slot,
...
}
=>
case ( tro::find_entry_by_module_stamp (result_typerstore, module_stamp),
tro::find_entry_by_module_stamp (constrained_package_typerstore, module_stamp)
)
( mld::PACKAGE_ENTRY result_typechecked_package,
mld::PACKAGE_ENTRY source_typechecked_package
)
=>
{ source_package
=
mld::A_PACKAGE {
an_api => this_spec_api,
typechecked_package => source_typechecked_package,
varhome => vh::select_varhome (constrained_package_varhome, slot),
inlining_data => id::select (constrained_package_inlining_data, slot)
};
inverse_path'
=
ip::extend (inverse_path, symbol);
my (thinned_declaration, thinned_package)
=
cast_package' (
source_package,
this_spec_api,
result_typechecked_package,
abstract_types,
symbol,
depth,
typerstore,
inverse_path',
symbolmapstack,
source_code_region,
per_compile_stuff
);
typerstore'
=
{ typechecked_package
=
case thinned_package
mld::A_PACKAGE { typechecked_package, ... } => typechecked_package;
_ => mld::bogus_typechecked_package;
esac;
tro::set (
typerstore,
module_stamp,
mld::PACKAGE_ENTRY typechecked_package
);
};
declarations' = thinned_declaration ! declarations;
symbolmapstack_entries' = (sxe::NAMED_PACKAGE thinned_package) ! symbolmapstack_entries;
cast_api_elements (remaining_api_elements, typerstore', declarations', symbolmapstack_entries');
};
_ =>
# Missing element, error situation -- do nothing:
#
cast_api_elements (remaining_api_elements, typerstore, declarations, symbolmapstack_entries);
esac;
mld::GENERIC_IN_API { a_generic_api => this_spec_api, module_stamp, slot }
=>
case ( tro::find_entry_by_module_stamp (result_typerstore, module_stamp),
tro::find_entry_by_module_stamp (constrained_package_typerstore, module_stamp)
)
( mld::GENERIC_ENTRY result_typechecked_generic,
mld::GENERIC_ENTRY source_typechecked_generic
)
=>
{ src_generic
=
mld::GENERIC {
a_generic_api => this_spec_api,
typechecked_generic => source_typechecked_generic,
varhome => vh::select_varhome (constrained_package_varhome, slot),
inlining_data => id::select (constrained_package_inlining_data, slot)
};
inverse_path'
=
ip::extend (inverse_path, symbol);
my (thinned_declaration, thinned_g)
=
pack_generic1 (
this_spec_api,
result_typechecked_generic,
src_generic,
abstract_types,
symbol,
depth,
typerstore,
inverse_path',
symbolmapstack,
source_code_region,
per_compile_stuff
);
typerstore'
=
{ typechecked_generic
=
case thinned_g
mld::GENERIC { typechecked_generic, ... } => typechecked_generic;
_ => mld::bogus_typechecked_generic;
esac;
tro::set (typerstore, module_stamp, mld::GENERIC_ENTRY typechecked_generic);
};
declarations' = thinned_declaration ! declarations;
symbolmapstack_entries' = (sxe::NAMED_GENERIC thinned_g) ! symbolmapstack_entries;
cast_api_elements (remaining_api_elements, typerstore', declarations', symbolmapstack_entries');
};
_ =>
cast_api_elements (remaining_api_elements, typerstore, declarations, symbolmapstack_entries);
esac;
mld::VALUE_IN_API { typoid => spec_type, slot }
=>
{ result_type = type_in_result ("@@@spec-resty (cast_package-my)", spec_type);
source_type = type_in_source ("@@@spec-srcty (cast_package-my)", spec_type);
varhome = vh::select_varhome (constrained_package_varhome, slot);
inlining_data = id::select (constrained_package_inlining_data, slot);
(try_unifying_pkg_with_api_type (result_type, source_type, inlining_data))
->
(types, generalized_typevars, type, result_unified_with_source_type);
path = syp::SYMBOL_PATH [symbol];
srcvar = vac::PLAIN_VARIABLE
{
path,
vartypoid_ref => REF source_type,
varhome,
inlining_data
};
my (declarations', named_variable)
=
if result_unified_with_source_type
#
(declarations, srcvar);
else
varhome = vh::named_varhome (symbol, make_var);
result_variable
=
vac::PLAIN_VARIABLE
{ path,
vartypoid_ref => REF result_type,
inlining_data => id::NIL,
varhome
};
ntypes = tj::filter_typeset (type, abstract_types);
expression
=
ds::ABSTRACTION_PACKING_EXPRESSION (
#
ds::VARIABLE_IN_EXPRESSION { var => REF srcvar, typescheme_args => types },
type,
ntypes
);
if (*debugging and ((list::length generalized_typevars) > 0))
printf "api-match-g.pkg: Creating ds::VALUE_NAMING node with length(generalized_typevars) d=%d (III)\n" (list::length generalized_typevars);
fi;
named_value = ds::VALUE_NAMING
{
pattern => (ds::VARIABLE_IN_PATTERN result_variable),
expression,
raw_typevars => REF [],
generalized_typevars
};
( (ds::VALUE_DECLARATIONS [named_value]) ! declarations,
result_variable
);
fi;
symbolmapstack_entries'
=
(sxe::NAMED_VARIABLE named_variable)
!
symbolmapstack_entries;
cast_api_elements
(
remaining_api_elements,
typerstore,
declarations',
symbolmapstack_entries'
);
};
mld::VALCON_IN_API
{
sumtype => tdt::VALCON
{
name,
typoid,
form,
is_constant,
signature,
is_lazy
},
slot
}
=>
{ symbolmapstack_entries'
=
case slot
#
NULL => symbolmapstack_entries;
THE s => { result_type
=
type_in_result ("@@@spec-resty (cast_package-con)", typoid);
varhome = vh::select_varhome (constrained_package_varhome, s);
con = tdt::VALCON { typoid => result_type,
form => exception_representation (form, varhome),
name,
is_lazy,
is_constant,
signature
};
(sxe::NAMED_CONSTRUCTOR (con)) ! symbolmapstack_entries;
};
esac;
cast_api_elements
(
remaining_api_elements,
typerstore,
declarations,
symbolmapstack_entries'
);
};
mld::TYPE_IN_API { type => type_per_api, module_stamp, is_a_replica, scope }
=>
{ typerstore'
=
tro::set (
typerstore,
module_stamp,
tro::find_entry_by_module_stamp (result_typerstore, module_stamp)
);
cast_api_elements
(
remaining_api_elements,
typerstore',
declarations,
symbolmapstack_entries
);
};
esac;
};
end; # fun cast_api_elements
my ( abstract_declarations,
symbolmapstack_entries
)
=
cast_api_elements (
api_elements,
typerstore,
[], # declarations accumulator.
[] # symbolmapstack_entries accumulator.
);
result_package
=
mld::A_PACKAGE
{
typechecked_package => result_typechecked_package,
#
an_api => constraining_api,
varhome => vh::make_varhome make_var,
inlining_data => id::LIST (map mj::extract_inlining_data symbolmapstack_entries)
};
result_declaration
=
ds::PACKAGE_DECLARATIONS
[
ds::NAMED_PACKAGE
{
name_symbol => package_name,
a_package => result_package,
definition
=>
ds::PACKAGE_LET
{
declaration => ds::SEQUENTIAL_DECLARATIONS abstract_declarations,
expression => ds::PACKAGE_DEFINITION symbolmapstack_entries
}
}
];
( result_declaration,
result_package
);
};
cast_package' _
=>
( ds::SEQUENTIAL_DECLARATIONS [],
mld::ERRONEOUS_PACKAGE
);
end # fun cast_package'
########################################################################################
# Abstraction matching of a package against an api.
#
# INVARIANT: The base api for pkg should be exactly an_api; in other
# words, a_package should have been matched against an_api before
# being packed against an_api.
#
# This gets invoked (only) from
# src/lib/compiler/front/typer/main/type-package-language-g.pkg #
########################################################################################
also
fun cast_package
{
constrained_package: mld::Package,
constraining_api: mld::Api,
package_expression: mld::Package_Expression,
debruijn_depth: di::Debruijn_Depth,
typerstore: mld::Typerstore,
inverse_path: ip::Inverse_Path,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff: trj::Per_Compile_Stuff
}
:
{ result_declaration: ds::Declaration,
result_package: mld::Package,
result_expression: mld::Package_Expression
}
=
{ if_debugging_say "cast_package/TOP";
my { typechecked_package => result_typechecked_package,
abstract_types,
type_stamppaths => _
}
=
{ source_typechecked_package
=
case constrained_package
#
mld::A_PACKAGE { typechecked_package, ... }
=>
typechecked_package;
_ => mld::bogus_typechecked_package;
esac;
gxs::instantiate_package_abstractions
{
an_api => constraining_api,
typerstore,
source_typechecked_package,
inverse_path,
source_code_region,
per_compile_stuff
};
};
if_debugging_say "cast_package - processing done";
abstract_types'
=
fold_backward
tj::insert_type_into_typeset
(tj::make_typeset())
abstract_types;
my (result_declaration, result_package)
=
cast_package'
(
constrained_package,
constraining_api,
result_typechecked_package,
abstract_types',
anonymous_package_symbol,
debruijn_depth,
typerstore,
inverse_path,
symbolmapstack,
source_code_region,
per_compile_stuff
);
if_debugging_say "cast_package - cast_package' done";
result_expression
=
mld::ABSTRACT_PACKAGE (
constraining_api,
package_expression
);
if_debugging_say "cast_package/BOT";
{ result_declaration,
result_package,
result_expression
};
} # fun cast_package
############################################################################
#
# fun pack_generic1: Packing a generic package against a generic api.
#
############################################################################
also
fun pack_generic1
( spec_api
as mld::GENERIC_API { parameter_api, parameter_variable, body_api, ... }
: mld::Generic_Api,
result_typechecked_generic: mld::Typechecked_Generic,
src_generic
as mld::GENERIC { typechecked_generic => source_typechecked_generic, ... }
: mld::Generic,
abstract_types1: type_junk::Typeset,
generic_name: sy::Symbol,
debruijn_depth: di::Debruijn_Depth,
typerstore: mld::Typerstore,
inverse_path: ip::Inverse_Path,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff
as { make_fresh_stamp, issue_highcode_codetemp=>make_var, error_fn, ... }
: trj::Per_Compile_Stuff
)
:
( ds::Declaration,
mld::Generic
)
=>
{ my { typechecked_package => param_typechecked_package,
typepaths => param_tps
}
=
gxs::do_generic_parameter_api {
an_api => parameter_api,
typerstore,
inverse_path => ip::INVERSE_PATH [generic_api_parameter_typechecked_package_symbol],
debruijn_depth,
source_code_region,
per_compile_stuff
};
debruijn_depth'
=
di::next debruijn_depth;
parameter_package
=
{ param_varhome
=
vh::make_varhome make_var;
mld::A_PACKAGE { an_api => parameter_api,
typechecked_package => param_typechecked_package,
varhome => param_varhome,
inlining_data => id::NIL
};
};
my { result_declaration => rdec1,
result_package => body_package,
result_expression => _
}
= apply_generic { a_generic => src_generic,
generic_expression => mld::CONSTANT_GENERIC source_typechecked_generic,
arg_package => parameter_package,
arg_expression => mld::CONSTANT_PACKAGE param_typechecked_package,
debruijn_depth => debruijn_depth',
inverse_path => ip::empty,
module_stamp_or_null => NULL,
stamppath_context => epc::init_context, # ? ZHONG
symbolmapstack,
source_code_region,
per_compile_stuff
};
# typechecked_body = expand_generic::expand_generic (srcGenericMacroExpansion, paramMacroExpansion, debruijn_depth', stamppath_context, per_compile_stuff) ;
#
typechecked_body
=
case body_package
mld::A_PACKAGE { typechecked_package, ... } => typechecked_package;
_ => mld::bogus_typechecked_package;
esac;
my { typechecked_package => result_typechecked_package,
abstract_types => abstract_types2,
type_stamppaths => _
}
=
{ typerstore'
=
tro::mark ( make_fresh_stamp,
tro::set (typerstore, parameter_variable, mld::PACKAGE_ENTRY param_typechecked_package)
);
gxs::instantiate_package_abstractions {
an_api => body_api,
typerstore => typerstore',
source_typechecked_package => typechecked_body,
inverse_path,
source_code_region,
per_compile_stuff
};
};
abstract_types
=
fold_backward
tj::insert_type_into_typeset
abstract_types1
abstract_types2;
my (rdec2, result_package)
=
{ inverse_path'
=
ip::INVERSE_PATH
[ sy::make_package_symbol "<GenericResult>" ];
cast_package' (
body_package,
body_api,
result_typechecked_package,
abstract_types,
anonymous_package_symbol,
debruijn_depth',
typerstore,
inverse_path',
symbolmapstack,
source_code_region,
per_compile_stuff
);
};
result_generic
=
{ result_varhome
=
vh::make_varhome make_var;
mld::GENERIC { a_generic_api => spec_api,
typechecked_generic => result_typechecked_generic,
varhome => result_varhome,
inlining_data => id::NIL
};
};
result_declaration
=
{ body
=
ds::PACKAGE_LET
{
declaration => rdec1,
expression
=>
ds::PACKAGE_LET {
declaration => rdec2,
expression => ds::PACKAGE_BY_NAME result_package
}
};
generic_expression
=
ds::GENERIC_DEFINITION {
parameter => parameter_package,
parameter_types => param_tps,
definition => body
};
ds::GENERIC_DECLARATIONS [
ds::NAMED_GENERIC {
name_symbol => generic_name,
a_generic => result_generic,
definition => generic_expression
}
];
};
( result_declaration,
result_generic
);
};
pack_generic1 _
=>
(ds::SEQUENTIAL_DECLARATIONS [], mld::ERRONEOUS_GENERIC);
end # function pack_generic1
#################################################################################
#
# fun apply_generic:
#
# Match and coerce the argument, then do the generic application.
# Return the result package, the result typechecked_package expression,
# and the result abstract syntax declaration of result_package.
#
# The argument matching takes place in the Typerstore stored in the
# generic closure; this is where the parameter_api must be interpreted.
#
#################################################################################
also
fun apply_generic
{
a_generic
as
mld::GENERIC { a_generic_api => mld::GENERIC_API { parameter_api, body_api, ... },
typechecked_generic,
...
},
generic_expression: mld::Generic_Expression,
arg_package: mld::Package,
arg_expression: mld::Package_Expression,
debruijn_depth: di::Debruijn_Depth,
symbolmapstack: syx::Symbolmapstack,
inverse_path: ip::Inverse_Path,
source_code_region: lnd::Source_Code_Region,
module_stamp_or_null: Null_Or( sta::Stamp ),
stamppath_context: spc::Context,
per_compile_stuff
as
{ issue_highcode_codetemp => make_var,
# make_fresh_stamp,
...
}
: trj::Per_Compile_Stuff
}
:
{ result_declaration: ds::Declaration,
result_package: mld::Package,
result_expression: mld::Package_Expression
}
=>
{ my { generic_closure => mld::GENERIC_CLOSURE { typerstore => generic_typerstore, ... }, ... }
=
typechecked_generic;
if_debugging_say "apply_generic/TOP";
# Step #1: match the argument package against parameter_api
#
my { result_declaration => arg_declaration1,
result_package => arg_package1,
coerced_package_expression => arg_expression1 # Coerced version of supplied package_expression argument.
}
=
thin_package {
constraining_api => parameter_api,
constrained_package => arg_package,
package_expression => arg_expression,
typerstore => generic_typerstore,
inverse_path => ip::INVERSE_PATH [] /* ?DAVE XXX BUGGO FIXME */,
module_stamp_or_null,
debruijn_depth,
symbolmapstack,
source_code_region,
per_compile_stuff
};
# ** step #2: do the generic application **
typechecked_argument
=
case arg_package1
#
mld::A_PACKAGE { typechecked_package, ... } => typechecked_package;
_ => mld::bogus_typechecked_package;
esac;
typechecked_body
=
expand_generic::expand_generic (
typechecked_generic,
typechecked_argument,
debruijn_depth,
stamppath_context,
inverse_path,
per_compile_stuff
);
result_package
=
{ body_varhome
=
vh::named_varhome (anonymous_package_symbol, make_var);
mld::A_PACKAGE { an_api => body_api,
typechecked_package => typechecked_body,
varhome => body_varhome,
inlining_data => id::NIL
};
};
result_declaration
=
{ parameter_types
=
gxs::get_packages_typepaths {
an_api => parameter_api,
typechecked_package => typechecked_argument,
typerstore => generic_typerstore,
per_compile_stuff
};
expression
=
ds::COMPUTED_PACKAGE {
generic_argument => arg_package1,
a_generic,
parameter_types
};
result_abs
=
ds::PACKAGE_LET { declaration => arg_declaration1, expression };
ds::PACKAGE_DECLARATIONS
[
ds::NAMED_PACKAGE
{
name_symbol => anonymous_package_symbol,
a_package => result_package,
definition => result_abs
}
];
};
result_expression
=
mld::APPLY (generic_expression, arg_expression1);
if_debugging_say "apply_generic/BOT";
{ result_declaration,
result_package,
result_expression
};
};
apply_generic { a_generic => mld::ERRONEOUS_GENERIC, ... }
=>
{ result_declaration => ds::PACKAGE_DECLARATIONS [],
result_package => mld::ERRONEOUS_PACKAGE,
result_expression => mld::CONSTANT_PACKAGE mld::bogus_typechecked_package
};
apply_generic _
=>
bug "apply_generic: bad generic package";
end; # fun apply_generic
# top level wrappers: used for profiling the compilation time
# thin_package
# =
# compile_statistics::do_phase (compile_statistics::make_phase "Compiler 034 1-thin_package") thin_package
#
# match_generic
# =
# compile_statistics::do_phase (compile_statistics::make_phase "Compiler 034 2-match_generic") match_generic
#
# cast_package
# =
# compile_statistics::do_phase (compile_statistics::make_phase "Compiler 034 3-cast_package") cast_package
#
# apply_generic
# =
# compile_statistics::do_phase (compile_statistics::make_phase "Compiler 034 4-apply_generic") apply_generic
}; # package api_match
end; # stipulate