## type-package-language-g.pkg
#
# See overview comments in:
#
# src/lib/compiler/front/typer/main/type-package-language.api# Compiled by:
# src/lib/compiler/front/typer/typer.sublib # Api_Match is from src/lib/compiler/front/typer/modules/api-match-g.pkg # Type_Core_Language_Declaration is from src/lib/compiler/front/typer/types/type-core-language-declaration-g.pkg # api_match is from src/lib/compiler/front/semantic/modules/api-match.pkg # type_core_language_declaration is from src/lib/compiler/front/semantic/types/type-core-language-declaration.pkgstipulate
package bug = typer_debugging; # typer_debugging is from src/lib/compiler/front/typer/main/typer-debugging.pkg package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package fst = find_in_symbolmapstack; # find_in_symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/find-in-symbolmapstack.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 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 mj = module_junk; # module_junk is from src/lib/compiler/front/typer-stuff/modules/module-junk.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package ppu = unparse_junk; # unparse_junk is from src/lib/compiler/front/typer/print/unparse-junk.pkg package prs = prettyprint_raw_syntax; # prettyprint_raw_syntax is from src/lib/compiler/front/typer/print/prettyprint-raw-syntax.pkg package raw = raw_syntax; # raw_syntax is from src/lib/compiler/front/parser/raw-syntax/raw-syntax.pkg package sta = stamp; # stamp is from src/lib/compiler/front/typer-stuff/basics/stamp.pkg package stx = stampmapstack; # stampmapstack is from src/lib/compiler/front/typer-stuff/modules/stampmapstack.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 ta = type_api; # type_api is from src/lib/compiler/front/typer/main/type-api.pkg package tcl = type_core_language; # type_core_language is from src/lib/compiler/front/typer/main/type-core-language.pkg package tro = typerstore; # typerstore is from src/lib/compiler/front/typer-stuff/modules/typerstore.pkg package trj = typer_junk; # typer_junk is from src/lib/compiler/front/typer/main/typer-junk.pkg package tt = type_type; # type_type is from src/lib/compiler/front/typer/main/type-type.pkg package tu = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.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;
include package module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg expand_oop_syntax_in_package_expression = expand_oop_syntax::expand_oop_syntax_in_package_expression;
expand_oop_syntax_in_package_expression2 = expand_oop_syntax2::expand_oop_syntax_in_package_expression;
herein
# We use a generic to factor out dependencies on highcode.
#
# This generic is invoked once, in
#
# src/lib/compiler/front/semantic/typecheck/type-package-language.pkg #
generic package type_package_language_g
(
package am: Api_Match;
package tcd: Type_Core_Language_Declaration; # type_core_language_declaration is from src/lib/compiler/front/semantic/types/type-core-language-declaration.pkg )
: (weak) Type_Package_Language
{
package ins = am::expand_generic::generics_expansion_junk; # "ins" might be "instantiate"
Package_Cast
= WEAK_PACKAGE_CAST
| STRONG_PACKAGE_CAST
| PARTIAL_PACKAGE_CAST
;
# Debugging:
#
say = control_print::say;
# debugging = typer_control::type_package_language_debugging; # eval: set_control "typechecker::type_package_language_debugging" "TRUE";
debugging = log::debugging;
# 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::type_package_language_debugging" "TRUE";
# eval: make "test.lib";
#
# This will spew debug printouts of various datastructures
# as the code in this file runs.
#
fun if_debugging_say (msg: String)
=
if *debugging
say msg;
say "\n";
fi;
#
fun bug msg
=
error_message::impossible("type_package_language: " + msg);
debug_print
=
\\ x = bug::debug_print debugging x;
#
fun unparse_raw_declaration
(
msg: String,
declaration: raw::Declaration,
symbolmapstack: syx::Symbolmapstack
)
=
if *debugging
print "\n";
print msg;
pp = standard_prettyprinter::make_standard_prettyprinter_into_file "/dev/stdout" [];
unparse_raw_syntax::unparse_declaration
(symbolmapstack, NULL)
pp
(declaration, 100);
pp.flush ();
pp.close ();
print "\n";
fi;
#
fun prettyprint_raw_declaration
(
msg: String,
declaration: raw::Declaration,
symbolmapstack: syx::Symbolmapstack
)
=
if *debugging
print "\n";
print msg;
pp = standard_prettyprinter::make_standard_prettyprinter_into_file "/dev/stdout" [];
prs::prettyprint_declaration
(symbolmapstack, NULL)
pp
(declaration, 100);
pp.flush ();
pp.close ();
print "\n";
fi;
#
fun unparse_deep_declaration
(
msg: String,
declaration: deep_syntax::Declaration,
symbolmapstack: syx::Symbolmapstack
)
=
if *debugging
print "\n";
print msg;
pp = standard_prettyprinter::make_standard_prettyprinter_into_file "/dev/stdout" [];
unparse_deep_syntax::unparse_declaration
(symbolmapstack, NULL)
pp
(declaration, 100);
pp.flush ();
pp.close ();
print "\n";
fi;
#
fun if_debugging_show_package (msg, a_package, symbolmapstack)
=
{
bug::with_internals
(\\ ()
=
debug_print
( msg,
(\\ pp = \\ a_package =
unparse_package_language::unparse_package pp (a_package, symbolmapstack, 100)
),
a_package)
);
if *debugging print "\n"; fi;
};
#
fun if_debugging_show_api (msg, an_api, symbolmapstack)
=
{
bug::with_internals
(\\ ()
=
debug_print
( msg,
(\\ pp = \\ an_api =
unparse_package_language::unparse_api pp (an_api, symbolmapstack, 100)
),
an_api)
);
if *debugging print "\n"; fi;
};
# fun show_symbolmapstack (msg, symbolmapstack)
# =
# if *debugging
# print "\n";
# print msg;
# pp = standard_prettyprinter::make_standard_prettyprinter_into_file "/dev/stdout" [];
#
# prettyprint_symbolmapstack::prettyprint_symbolmapstack
# pp
# symbolmapstack;
#
# pp.flush ();
# pp.close ();
# print "\n";
# fi;
#
fun show_generic (msg, a_generic, symbolmapstack)
=
bug::with_internals
(\\ ()
=
debug_print
( msg,
(\\ pp = \\ a_generic'
=
unparse_package_language::unparse_generic pp (a_generic', symbolmapstack, 100)
),
a_generic)
);
# Check if a typechecked_package declaration is empty
# in order to avoid the unnecessary recompilation
# bug reported by Matthias Blume (ZHONG)
#
fun module_declaration_is_not_empty ( mld::EMPTY_GENERIC_EVALUATION_DECLARATION
| mld::SEQUENTIAL_DECLARATIONS []
)
=>
FALSE;
module_declaration_is_not_empty _
=>
TRUE;
end;
#
fun module_declaration_sequence declarations
=
{ nodes = list::filter
module_declaration_is_not_empty
declarations;
case nodes
#
[] => mld::EMPTY_GENERIC_EVALUATION_DECLARATION;
_ => mld::SEQUENTIAL_DECLARATIONS nodes;
esac;
};
#
fun local_module_declaration (d1, d2)
=
module_declaration_sequence [d1, d2];
include package special_symbols; # A dozen symbols like <parameter> <generic> <genericbody> ...
#
fun strip_source_code_region_data_from_named_api (
raw::SOURCE_CODE_REGION_FOR_NAMED_API (
api_naming',
source_code_region'
),
source_code_region
)
=>
strip_source_code_region_data_from_named_api (api_naming', source_code_region');
strip_source_code_region_data_from_named_api x
=>
x;
end;
#
fun strip_source_code_region_data_from_named_generic_api
(
raw::SOURCE_REGION_FOR_NAMED_GENERIC_API (
generic_api_naming',
source_code_region'
),
source_code_region
)
=>
strip_source_code_region_data_from_named_generic_api (generic_api_naming', source_code_region');
strip_source_code_region_data_from_named_generic_api x
=>
x;
end;
#
fun strip_source_code_region_data_from_named_generics
(
raw::SOURCE_CODE_REGION_FOR_NAMED_GENERIC (
generic_naming',
source_code_region'),
source_code_region
)
=>
strip_source_code_region_data_from_named_generics (generic_naming', source_code_region');
strip_source_code_region_data_from_named_generics x
=>
x;
end;
#
fun strip_source_code_region_data_from_named_package (
raw::SOURCE_CODE_REGION_FOR_NAMED_PACKAGE (
named_package',
source_code_region'
),
source_code_region
)
=>
strip_source_code_region_data_from_named_package (named_package', source_code_region');
strip_source_code_region_data_from_named_package x
=>
x;
end;
# Change of syntactic_typechecking_context on entering a package
#
fun enter_package trj::AT_TOPLEVEL
=>
trj::IN_PACKAGE;
enter_package z
=>
z;
end;
# Add mod_id to stamppath mappings
# for all appropriate elements of a package
# that has just been typechecked.
#
# If stamppath_context is the empty context
# (rigid), then this is an expensive no-op, so we
# test stamppath_context first.
#
# But, would this be equivalent to context=INFCT _ ? XXX BUGGO FIXME ("INFCT" may be "in functor", i.e., "in generic")
#
# stamppath_context is the stamppath_context
# for the interior of the package -- i.e. the package
# naming's Module_Stamp has been added to the bind_context
#
# map_paths is quite heavyweight right now. XXX BUGGO FIXME
# It can be simplified in several ways.
# First, all type stamps don't have to be remapped,
# if new type stamps are mapped by macro_expand, then each map_paths
# only need to deal with packages and generics.
# Even dealing with packages and generics can be distributed
# into the api matching or the instantiation process. (ZHONG)
# map_paths_phase = (compile_statistics::make_phase "Compiler 033 1-map_paths")
# also map_paths x = compile_statistics::do_phase map_paths_phase map_paths0 x
#
fun map_paths ( stamppath_context,
A_PACKAGE { an_api, typechecked_package, ... },
flex # "Definition of SML" calls typcons from apis "flexible" an all others "rigid".
)
=>
map_stamppath_context
(
stamppath_context,
an_api,
typechecked_package,
flex
);
map_paths _ => ();
end
also
fun map_stamppath_context
(
stamppath_context,
an_api as API { api_elements, ... },
typechecked_package: mld::Typechecked_Package,
flex
)
=>
{ typechecked_package -> { typerstore, ... };
#
if (not (spc::is_empty stamppath_context))
#
list::apply do_element api_elements;
fi
where
fun do_element (_, TYPE_IN_API { module_stamp, ... } )
=>
# bind only if type is flexible -- have to pass flexibility "Definition of SML" calls typcons from apis "flexible" an all others "rigid".
# tester -- but wait! what about a rigid package with a
# new api? Have to record even rigid packages and generics in
# case they have new apis
#
case (tro::find_entry_by_module_stamp (typerstore, module_stamp))
#
TYPE_ENTRY type
=>
case type
#
tdt::ERRONEOUS_TYPE => ();
_ =>
{ stamp = tu::stamp_of_type type;
#
if (flex stamp)
#
spc::bind_typepath(
stamppath_context,
stx::typestamp_of' type,
module_stamp
);
fi;
};
esac;
#
ERRONEOUS_ENTRY => ();
#
_ => bug "map_macro_expansion_path_context 1";
esac;
do_element (_, PACKAGE_IN_API { module_stamp, an_api => this_api, ... } )
=>
# Map this package (unconditionally, because it may
# have a different api)
#
case this_api # Don't record ERRONEOUS_API -- error tolerance
#
API _
=>
case (tro::find_entry_by_module_stamp (typerstore, module_stamp))
#
PACKAGE_ENTRY nr
=>
{ i = mj::make_packagestamp (this_api, nr);
#
case (spc::find_stamppath_for_package (stamppath_context, i))
#
THE _ => ();
_ => { spc::bind_stamppath (stamppath_context, i, module_stamp);
map_stamppath_context (
spc::enter_open (stamppath_context, THE module_stamp),
this_api,
nr,
flex
);
};
esac;
};
ERRONEOUS_ENTRY => ();
_ => bug "map_macro_expansion_path_context 2";
esac;
ERRONEOUS_API => ();
esac;
do_element (_, GENERIC_IN_API { module_stamp, a_generic_api => this_api, ... } )
=>
# Map this generic (unconditionally):
#
case this_api
#
GENERIC_API _
=>
case (tro::find_entry_by_module_stamp (typerstore, module_stamp))
#
GENERIC_ENTRY nr
=>
{ i = mj::make_genericstamp (this_api, nr);
#
spc::bind_generic_path (stamppath_context, i, module_stamp);
};
ERRONEOUS_ENTRY => ();
_ => bug "map_macro_expansion_path_context 3";
esac;
ERRONEOUS_GENERIC_API => ();
esac;
do_element _ => ();
end; # fun do_element
end; # where
};
map_stamppath_context _ => ();
end;
# ASSERT: order of DEFtypes in types respects dependencies, i.e. no
# NAMED_TYPE refers to types occurring after itself.
#
fun bind_new_types (trj::IN_GENERIC _, epctxt, make_stamp, dtypes, wtypes, inverse_path, err)
=>
{ fun strip_path path
=
{ name_path = ip::INVERSE_PATH [ip::last path];
prefix = ip::last_prefix path;
if (not (ip::equal (inverse_path, prefix)) )
err err::WARNING
"Harmless compiler bug: bad type path prefix"
err::null_error_body;
fi;
name_path;
};
vizty = (\\ typoid = #1 (mj::relativize_typoid epctxt typoid));
viztc = (\\ tc = #1 (mj::relativize_type epctxt tc ));
# This is ok because stamppath_context has state; a bit ugly XXX BUGGO FIXME
#
new_dtypes
=
case dtypes
#
(tdt::SUM_TYPE { kind, ... } ! _)
=>
case kind
#
tdt::SUMTYPE { index => 0, family, free_types, stamps, root }
=>
{ rootev = make_stamp();
rtev_op = THE rootev;
nfreetypes = map viztc free_types;
nstamps = vector::map (\\ _ = make_stamp()) stamps;
map new_sumtype dtypes
where
fun new_sumtype (dt as tdt::SUM_TYPE { kind, arity, is_eqtype, namepath, ... } )
=>
case kind
#
tdt::SUMTYPE { index, ... }
=>
{ my (module_stamp, rtev)
=
if (index == 0) (rootev, NULL );
else (make_stamp(), rtev_op);
fi;
nkind
=
tdt::SUMTYPE { index,
stamps => nstamps,
free_types => nfreetypes,
root => rtev,
family
};
# The rtev field in SUMTYPE indicates
# how to discover the new stamps when
# such sumtypes get evalent-ed.
#
ndt = tdt::SUM_TYPE
{
arity,
is_eqtype,
#
kind => nkind,
namepath => strip_path namepath,
stamp => vector::get (nstamps, index),
stub => NULL
};
spc::bind_typepath (
epctxt,
mj::typestamp_of dt,
module_stamp
);
( module_stamp,
dt,
mld::FORMAL_TYPE ndt
);
};
_ => bug "unexpected case in new_sumtypeyc (1)";
esac;
new_sumtype _ => bug "unexpected case in new_sumtypeyc (2)";
end; # fun new_sumtype
end; # where
};
_ => bug "unexpected types in bind_new_types (1)";
esac;
[] => [];
_ => bug "unexpected types in bind_new_types (2)";
esac;
nwtypes
=
map newtc wtypes
where
fun newtc (tc as tdt::NAMED_TYPE { typescheme => tdt::TYPESCHEME { arity, body },
stamp,
strict,
namepath
}
)
=>
{ module_stamp = make_stamp ();
#
spc::bind_typepath (epctxt, mj::typestamp_of tc, module_stamp);
ntc = tdt::NAMED_TYPE {
stamp => make_stamp(),
strict,
namepath => strip_path namepath,
typescheme => tdt::TYPESCHEME { arity, body => vizty body }
};
( module_stamp,
tc,
mld::FORMAL_TYPE ntc
);
};
newtc _ => bug "unexpected case in newwtyc";
end;
end;
#
fun bind ( (module_stamp, tc, te) ! tcs,
typerstore,
typechecked_package_decs
)
=>
bind( tcs,
tro::set( typerstore,
module_stamp,
mld::TYPE_ENTRY( tc )
),
mld::TYPE_DECLARATION (module_stamp, te) ! typechecked_package_decs
);
bind (NIL, typerstore, typechecked_package_decs)
=>
( tro::mark( make_stamp, typerstore ),
module_declaration_sequence( reverse typechecked_package_decs )
);
end;
bind( new_dtypes @ nwtypes,
tro::empty,
[]
);
};
bind_new_types _
=>
( tro::empty,
mld::EMPTY_GENERIC_EVALUATION_DECLARATION
);
end;
###########################################################################
# #
# Extract API etc info from a symbol table. #
# #
# Recompute dynamic accesses after the elaboration of a package body, #
# replacing the original dynamic access by a SLOT and generating a #
# thinning that will be used (in translate) to create the package #
# record. #
# #
# Recompute all the dynamic accesses in an dictionary, suppress doubles #
# and allot slots. Components are ordered so that slot allocation is #
# independent of the way elaboration is done. #
# #
# Should we use dictionary::fold or dictionary::map? #
# #
###########################################################################
#
fun extract_symbolmapstack_contents
(
symbolmapstack: syx::Symbolmapstack,
stamppath_context: spc::Context,
syntactic_typechecking_context: trj::Syntactic_Typechecking_Context, # TOPLEVEL/API/PKG/GENERIC
per_compile_stuff as { make_fresh_stamp, ... }: trj::Per_Compile_Stuff
)
:
( List( (symbol::Symbol, mld::Api_Element ) ), # api_elements
mld::Typerstore, # typerstore
List( Module_Declaration ), # module_declarations
List( symbolmapstack_entry::Symbolmapstack_Entry ), # locations
Bool # contains_generic
)
=
{ fun get_modulepath_or_null (get, mod_id)
=
case syntactic_typechecking_context
trj::IN_GENERIC _ => get (stamppath_context, mod_id);
_ => NULL;
esac;
relativize
=
case syntactic_typechecking_context
#
trj::IN_GENERIC _ => \\ typoid = #1 (mj::relativize_typoid stamppath_context typoid);
_ => \\ x = x;
esac;
# We call this once for each entry in the symbol table.
#
# The first argument is the name/entry symbol table pair.
#
# The second argument holds the lists etc in which
# we accumulate extracted symbol table entry
# information.
#
# We discard the 'slot_count' variable when we complete
# reading all the symbol table entries; we use it only
# for assigning successive package record slots to
# VALUE_IN_API records etc.
#
fun note_named_symbolmapstack_entry
(
# Named entry to note:
#
( symbol: symbol::Symbol,
symbolmapstack_entry: sxe::Symbolmapstack_Entry
),
# Info from previously noted
# named entries:
#
{ named_api_elements: List( (symbol::Symbol, Api_Element) ),
typerstore: Typerstore,
module_declarations: List( Module_Declaration ),
symbolmapstack_entries: List( sxe::Symbolmapstack_Entry ),
slot_count: Int,
contains_generic: Bool
}
)
=
case symbolmapstack_entry
#
sxe::NAMED_VARIABLE( vac::PLAIN_VARIABLE { vartypoid_ref, path, ... } )
=>
{ api_element
=
VALUE_IN_API {
typoid => relativize *vartypoid_ref,
slot => slot_count
};
named_api_elements = (symbol, api_element) ! named_api_elements;
symbolmapstack_entries = symbolmapstack_entry ! symbolmapstack_entries;
slot_count = slot_count + 1;
{ named_api_elements,
typerstore,
module_declarations,
symbolmapstack_entries,
slot_count,
contains_generic
};
};
sxe::NAMED_CONSTRUCTOR (
valcon as tdt::VALCON {
name,
is_constant,
is_lazy,
signature,
typoid,
form
}
)
=>
{ typoid = relativize typoid;
#
my ( form,
symbolmapstack_entries,
slot,
slot_count
)
=
case form
#
vh::EXCEPTION _
=>
( vh::EXCEPTION (vh::null_varhome),
symbolmapstack_entry ! symbolmapstack_entries,
THE slot_count,
slot_count + 1
);
_ => (form, symbolmapstack_entries, NULL, slot_count);
esac;
sumtype = tdt::VALCON
{
name,
is_constant,
signature,
typoid,
form,
is_lazy
};
sumtype = VALCON_IN_API { sumtype, slot };
named_api_elements = (symbol, sumtype) ! named_api_elements;
{ named_api_elements,
typerstore,
module_declarations,
symbolmapstack_entries,
slot_count,
contains_generic
};
};
sxe::NAMED_PACKAGE ( a_package as A_PACKAGE { an_api, typechecked_package, ... } )
=>
{ modulepath_or_null
=
get_modulepath_or_null (
spc::find_stamppath_for_package,
mj::packagestamp_of a_package
);
my ( module_stamp,
typerstore,
module_declarations
)
=
case modulepath_or_null
#
THE [module_stamp]
=>
( module_stamp,
typerstore,
module_declarations
);
_ =>
(module_stamp, ee, ed)
where
module_stamp = make_fresh_stamp ();
ee = tro::set (typerstore, module_stamp, PACKAGE_ENTRY typechecked_package);
ed = case syntactic_typechecking_context
#
trj::IN_GENERIC _
=>
{ package_expression
=
case modulepath_or_null
THE stamppath => mld::VARIABLE_PACKAGE stamppath;
_ => mld::CONSTANT_PACKAGE typechecked_package;
esac;
(mld::PACKAGE_DECLARATION (module_stamp, package_expression, symbol))
!
module_declarations;
};
_ => module_declarations;
esac;
end;
esac;
api_element
=
PACKAGE_IN_API {
slot => slot_count,
definition => NULL,
an_api,
module_stamp
};
named_api_elements = (symbol, api_element) ! named_api_elements;
symbolmapstack_entries = symbolmapstack_entry ! symbolmapstack_entries;
slot_count = slot_count + 1;
contains_generic
=
case an_api
API sg => contains_generic or sg.contains_generic;
_ => contains_generic;
esac;
{ named_api_elements,
typerstore,
module_declarations,
symbolmapstack_entries,
slot_count,
contains_generic
};
};
sxe::NAMED_GENERIC ( a_generic as GENERIC { a_generic_api, typechecked_generic, ... } )
=>
{ modulepath_or_null
=
get_modulepath_or_null (spc::find_stamppath_for_generic, mj::genericstamp_of a_generic);
my ( module_stamp,
typerstore,
module_declarations
)
=
case modulepath_or_null
#
THE [x] => (x, typerstore, module_declarations);
_ =>
(x, ee, ed)
where
x = make_fresh_stamp ();
ee = tro::set (typerstore, x, GENERIC_ENTRY typechecked_generic);
ed = case syntactic_typechecking_context
trj::IN_GENERIC _
=>
{ generic_expression
=
case modulepath_or_null
THE stamppath => mld::VARIABLE_GENERIC stamppath;
_ => mld::CONSTANT_GENERIC typechecked_generic;
esac;
(mld::GENERIC_DECLARATION (x, generic_expression))
!
module_declarations;
};
_ => module_declarations;
esac;
end; # where
esac;
api_element
=
GENERIC_IN_API {
slot => slot_count,
a_generic_api,
module_stamp
};
named_api_elements = (symbol, api_element) ! named_api_elements;
symbolmapstack_entries = symbolmapstack_entry ! symbolmapstack_entries;
slot_count = slot_count + 1;
contains_generic = TRUE;
{ named_api_elements,
typerstore,
module_declarations,
symbolmapstack_entries,
slot_count,
contains_generic
};
};
sxe::NAMED_TYPE type
=>
{ modulepath_or_null
=
case type
#
tdt::ERRONEOUS_TYPE => NULL;
_ => get_modulepath_or_null (
spc::find_stamppath_for_type,
mj::typestamp_of type
);
esac;
my ( module_stamp,
typerstore,
module_declarations
)
=
case modulepath_or_null
THE [x] => (x, typerstore, module_declarations);
_ =>
(x, ee, ed)
where
x = make_fresh_stamp ();
ee = tro::set (typerstore, x, TYPE_ENTRY type);
ed = case syntactic_typechecking_context
#
trj::IN_GENERIC _
=>
{ typechecked_type_expression
=
case modulepath_or_null
#
THE stamppath => mld::TYPEVAR_TYPE stamppath;
_ => mld::CONSTANT_TYPE type;
esac;
(mld::TYPE_DECLARATION (x, typechecked_type_expression))
!
module_declarations;
};
_ => module_declarations;
esac;
end; # where
esac;
api_element
=
TYPE_IN_API {
type => tdt::ERRONEOUS_TYPE,
is_a_replica => FALSE,
scope => 0,
module_stamp
};
named_api_elements = (symbol, api_element) ! named_api_elements;
# Use of tdt::ERRONEOUS_TYPE above is a hack.
#
# It relies on the fact that the inferred api
# would never be macro expanded or api-matched
# against anyway.
#
# One might wonder what about a generic declaration
# with no result api constraint -- the
# inferred Generic_Api would contain
# tdt::ERRONEOUS_TYPE -- but fortunately
# the result api in this Generic_Api
# would never be matched against either. (ZHONG)
{ named_api_elements,
typerstore,
module_declarations,
symbolmapstack_entries,
slot_count,
contains_generic
};
};
_ => { named_api_elements,
typerstore,
module_declarations,
symbolmapstack_entries,
slot_count,
contains_generic
};
esac; # fun note_named_symbolmapstack_entry
named_symbolmapstack_entries
=
syx::to_sorted_list (syx::consolidate symbolmapstack);
(list::fold_forward
note_named_symbolmapstack_entry
{ named_api_elements => ([]: List( (symbol::Symbol, Api_Element) )),
typerstore => tro::empty,
module_declarations => ([]: List( Module_Declaration )),
symbolmapstack_entries => ([]: List( sxe::Symbolmapstack_Entry )),
slot_count => 0,
contains_generic => FALSE
}
(named_symbolmapstack_entries: List ((symbol::Symbol, syx::Entry)))
)
->
{ named_api_elements,
typerstore,
module_declarations,
symbolmapstack_entries,
slot_count, # Discarded at this point.
contains_generic
};
( reverse named_api_elements,
typerstore,
reverse module_declarations,
reverse symbolmapstack_entries,
contains_generic
);
}; # fun extract_symbolmapstack_contents
# 2009-08-10 CrT:
# THIS IS NOT WORKING. It radiated
# error conditions into parts of the
# backend I do not understand well
# enough to modify appropriately.
#
# I implemented this before I realized
# that parts of a package can be selectively
# strong-sealed by putting them in a subpackage,
# sealing it, and then including it back into
# the main package.
#
# Now that I'm more aware of that hack,
# I'm undecided as to whether the PARTIAL_CAST
# idea is worth pursuing.
#
# This is our core hack to implement
# partial package casting ("sealing").
#
# The only difference between strong and
# partial package casting is that strong
# package casting hides all package elements
# not explicitly listed in the api, whereas
# partial package casting leaves unmentioned
# elements visible and unchanged.
#
# This function conditionally extends the api
# with all unmentioned elements from the package,
# thereby reducing partial package casting to
# the already-implemented case of strong package
# casting.
#
#
# Our three input arguments are:
#
# o The constraining api (if any).
#
# o The cast operation. We do nothing
# unless it is PARTIAL_PACKAGE_CAST.
#
# o The constrained package.
#
# o The associated symbol table.
#
#
# We return three results:
#
# o The constraining API, possibly augmented
# with new elements.
#
# o The cast operation, possibly changed
# from PARTIAL_PACKAGE_CAST
# to STRONG_PACKAGE_CAST.
#
fun maybe_extend_api_to_cover_package
(
constraining_api_or_null: Null_Or( mld::Api ),
package_cast: Package_Cast, # How to apply constraining API -- strong/weak/partial cast.
a_package: mld::Package,
symbolmapstack: syx::Symbolmapstack
)
:
( Null_Or( mld::Api ), # constraining_api_or_null
Package_Cast, # package_cast
syx::Symbolmapstack # symbolmapstack
)
=
{
if *debugging
case package_cast
WEAK_PACKAGE_CAST => print "maybe_extend_api_to_cover_package: This is a WEAK cast.\n";
STRONG_PACKAGE_CAST => print "maybe_extend_api_to_cover_package: This is a STRONG cast.\n";
PARTIAL_PACKAGE_CAST => print "maybe_extend_api_to_cover_package: This is a PARTIAL cast.\n";
esac;
fi;
case package_cast
#
PARTIAL_PACKAGE_CAST
=>
case (constraining_api_or_null, a_package)
#
( THE (old_api as API { stamp, name, stub, api_elements => constraining_elements, closed, symbols, property_list, contains_generic, type_sharing, package_sharing } ),
A_PACKAGE { an_api => API { api_elements => constrained_elements, ... }, ... }
)
=>
{ # The difference between PARTIAL_PACKAGE_CAST
# and STRONG_PACKAGE_CAST is just that the latter
# hides all package elements not explicitly listed
# in the API, whereas the former passes through
# unchanged all package elements not mentioned
# by the api.
{ old_debug_setting = *debugging;
debugging := TRUE;
if_debugging_show_api ("maybe_extend_api_to_cover_package: original api: -- type-package-language-g.pkg", old_api, symbolmapstack);
if_debugging_show_package ("maybe_extend_api_to_cover_package: constrained_package: --type-package-language-g.pkg", a_package, symbolmapstack);
debugging := old_debug_setting;
};
fun print_elements []
=>
();
print_elements ((symbol, api_element: mld::Api_Element) ! rest)
=>
{ printf " api element: %s\n" (sy::name symbol);
print_elements rest;
};
end;
printf "Initial constraining elements: \n"; print_elements constraining_elements;
printf "Initial constrained elements: \n"; print_elements constrained_elements;
constraining_elements
=
(reverse constrained_elements)
@
constraining_elements;
# constraining_elements;
# constrained_elements @ constraining_elements;
printf "Final constraining elements: \n"; print_elements constraining_elements;
# We implement that here by adding to the api 'elements'
# list all "missing" elements in it present in the package.
# With this done, we can then proceed with further processing
# exactly as in the STRONG_PACKAGE_CAST case.
# We start by sorting both lists:
#
# fun elem_eq ((s1, _), (s2, _)) = sy::eq (s1, s2);
# fun elem_gt ((s1, _), (s2, _)) = sy::symbol_gt (s1, s2);
#
# constraining_elements = list_mergesort::sort elem_gt constraining_elements;
# constrained_elements = list_mergesort::sort elem_gt constrained_elements;
#
#
# # We now merge the two sorted lists to produce the new
# # constraining_elements list, favoring constraining
# # over constrained elements whenever there is a choice:
# #
# constraining_elements
# =
# left_favoring_merge( constraining_elements, constrained_elements, [] )
# where
# # "s1" == "symbol1", "e1" == "element1" etc:
# #
# fun left_favoring_merge (list1 as (e1 ! rest1), list2 as (e2 ! rest2), results)
# =>
# if (elem_eq (e1, e2)) left_favoring_merge (rest1, rest2, e1 ! results);
# elif (elem_gt (e1, e2)) left_favoring_merge (list1, rest2, e2 ! results);
# else left_favoring_merge (rest1, list2, e1 ! results);
# fi;
#
# left_favoring_merge ( [], e2 ! rest2, results) => left_favoring_merge ([], rest2, e2 ! results);
# left_favoring_merge (e1 ! rest1, [], results) => left_favoring_merge (rest1, [], e1 ! results);
# left_favoring_merge ( [], [], results) => reverse results;
# end;
# end;
# Reconstitute the constraining API with
# the new elements and symbols lists:
#
new_api = API { api_elements => constraining_elements,
symbols => map #1 constraining_elements,
stamp,
name,
stub,
closed,
property_list,
contains_generic,
type_sharing,
package_sharing
};
# Old API is still in symbol table,
# so we need to override it:
#
symbolmapstack
=
case name
THE symbol => syx::bind (symbol, sxe::NAMED_API new_api, symbolmapstack);
NULL => symbolmapstack;
esac;
{ old_debug_setting = *debugging;
debugging := TRUE;
if_debugging_show_api ("maybe_extend_api_to_cover_package: extended api: --type-package-language-g.pkg", new_api, symbolmapstack);
debugging := old_debug_setting;
};
# show_symbolmapstack ("--maybe_extend_api_to_cover_package: symbol table: ", symbolmapstack)
if_debugging_say "maybe_extend_api_to_cover_package. --type-package-language-g.pkg\n";
( THE new_api,
STRONG_PACKAGE_CAST,
symbolmapstack
);
};
other => (constraining_api_or_null, package_cast, symbolmapstack); # No change.
esac;
other => (constraining_api_or_null, package_cast, symbolmapstack); # No change.
esac;
};
############################################################################
# #
# The type_constrained_package function is used to #
# perform api matching on package declarations with package casts. #
# #
# The "package_cast" argument is used to indicate whether the #
# package cast is strong, weak or partial. #
# #
############################################################################
#
fun type_constrained_package
(
constrained_package: mld::Package, # Package to be constrained by api.
package_cast: Package_Cast, # How to apply constraining API -- strong/weak/partial cast.
constraining_api: mld::Api, # Api to constrain package.
#
package_declaration: ds::Declaration,
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, # Combines both info from all .compiled files we depend on and info from raw-syntax being processed.
#
source_code_region: lnd::Source_Code_Region,
per_compile_stuff: trj::Per_Compile_Stuff
)
:
( ds::Declaration,
mld::Package,
mld::Package_Expression
)
=
{
if_debugging_say "type_constrained_package/TOP -- type-package-language-g.pkg";
if *debugging
case package_cast
WEAK_PACKAGE_CAST => print "type_constrained_package: This is a WEAK cast.\n";
STRONG_PACKAGE_CAST => print "type_constrained_package: This is a STRONG cast.\n";
PARTIAL_PACKAGE_CAST => print "type_constrained_package: This is a PARTIAL cast.\n";
esac;
fi;
if_debugging_show_package ("type_constrained_package/TOP: constrained_package: --type-package-language-g.pkg", constrained_package, symbolmapstack);
if_debugging_show_api ("type_constrained_package/TOP: constraining_api: --type-package-language-g.pkg", constraining_api, symbolmapstack);
unparse_deep_declaration ("type_constrained_package/TOP: unparsing package_declaration deep syntax: --type-package-language-g.pkg", package_declaration, symbolmapstack);
my { result_declaration => result_declaration1: ds::Declaration,
result_package => result_package1: mld::Package,
coerced_package_expression => result_package_expression1: mld::Package_Expression
}
=
am::thin_package # thin_package def in src/lib/compiler/front/typer/modules/api-match-g.pkg {
constrained_package, # Check this package
constraining_api, # against this api.
module_stamp_or_null,
debruijn_depth,
package_expression,
typerstore,
inverse_path,
symbolmapstack,
source_code_region,
per_compile_stuff
};
if_debugging_say "type_constrained_package: am::thin_package done --type-package-language-g.pkg";
if_debugging_show_package ("type_constrained_package: result_package1: --type-package-language-g.pkg", result_package1, symbolmapstack);
unparse_deep_declaration ("type_constrained_package: unparsing result_declaration1 deep syntax: --type-package-language-g.pkg", result_declaration1, symbolmapstack);
if *debugging
case package_cast
WEAK_PACKAGE_CAST => print "type_constrained_package: This is a WEAK cast.\n";
STRONG_PACKAGE_CAST => print "type_constrained_package: This is a STRONG cast.\n";
PARTIAL_PACKAGE_CAST => print "type_constrained_package: This is a PARTIAL cast.\n";
esac;
fi;
case package_cast
#
WEAK_PACKAGE_CAST
=>
( ds::SEQUENTIAL_DECLARATIONS [package_declaration, result_declaration1],
result_package1,
result_package_expression1
);
STRONG_PACKAGE_CAST
=>
{ my { result_declaration => result_declaration2,
result_package => result_package2,
result_expression => result_expression2
}
=
am::cast_package # cast_package def in src/lib/compiler/front/typer/modules/api-match-g.pkg {
constrained_package => result_package1,
constraining_api,
package_expression => result_package_expression1,
debruijn_depth,
inverse_path,
symbolmapstack,
typerstore,
source_code_region,
per_compile_stuff
};
if_debugging_say "type_constrained_package[STRONG_PACKAGE_CAST]: am::cast_package done --type-package-language-g.pkg";
if_debugging_show_package ("type_constrained_package[STRONG_PACKAGE_CAST]: result_package2: --type-package-language-g.pkg", result_package2, symbolmapstack);
unparse_deep_declaration ("type_constrained_package[STRONG_PACKAGE_CAST]: unparsing result_declaration2 deep syntax: --type-package-language-g.pkg", result_declaration2, symbolmapstack);
( ds::SEQUENTIAL_DECLARATIONS [ package_declaration, result_declaration1, result_declaration2 ],
result_package2,
result_expression2
);
};
# XXX BUGGO FIXME 2009-03-22 CrT: This is at the moment just a clone of the above case:
PARTIAL_PACKAGE_CAST
=>
{ my { result_declaration => result_declaration2,
result_package => result_package2,
result_expression => result_expression2
}
=
am::cast_package
{
constrained_package => result_package1,
constraining_api,
package_expression => result_package_expression1,
debruijn_depth,
inverse_path,
symbolmapstack,
typerstore,
source_code_region,
per_compile_stuff
};
if_debugging_say "type_constrained_package[PARTIAL_PACKAGE_CAST]: am::cast_package done --main/type-package-language-g.pkg";
if_debugging_show_package ("type_constrained_package[PARTIAL_PACKAGE_CAST]: result_package2: --main/type-package-language-g.pkg", result_package2, symbolmapstack);
unparse_deep_declaration ("type_constrained_package[PARTIAL_PACKAGE_CAST]: unparsing result_declaration2 deep syntax: --main/type-package-language-g.pkg",
result_declaration2, symbolmapstack);
( ds::SEQUENTIAL_DECLARATIONS [ package_declaration, result_declaration1, result_declaration2 ],
result_package2,
result_expression2
);
};
esac;
};
# type_package: typecheck the raw package, without api constraint:
# Several invariants:
# Every package_expression
# is now typechecked into a quadruple
# ( deep_syntax_tree,
# resulting_package_expression, # Gets folded into module_declarations result.
# macro expansion expressions,
# delta macro expansion dictionary
# )
# where the latter was collected while typechecking
# the current package expression.
#
# The macro expansion dictionary delta is
# designed to deal with LET_IN_PACKAGE
# and LET_IN_GENERIC and to maintain the
# hidden typechecked_package dictionary context.
#
fun type_package
(
package_body_to_typecheck: raw::Package_Expression, # package body to typecheck
name: Null_Or( sy::Symbol ),
symbolmapstack: syx::Symbolmapstack,
typerstore: mld::Typerstore,
syntactic_typechecking_context: trj::Syntactic_Typechecking_Context,
stamppath_context: spc::Context,
module_stamp_v: Null_Or( sta::Stamp ),
inverse_path: ip::Inverse_Path,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff as { issue_highcode_codetemp=>make_var, make_fresh_stamp, error_fn, ... }: trj::Per_Compile_Stuff
)
:
( ds::Declaration,
mld::Package,
mld::Package_Expression,
tro::Typerstore
)
=
{ debruijn_depth
=
case syntactic_typechecking_context
#
trj::IN_GENERIC { debruijn_depth, ... } => debruijn_depth;
_ => di::top;
esac;
if_debugging_say ("type_package: [type-package-language-g.pkg]" + pkg_name)
where
pkg_name = case name THE n => sy::name n;
NULL => "<anonymous>";
esac;
end;
# type_package':
# ( raw::Package_Expression,
# Symbolmapstack,
# Typerstore,
# Source_Code_Region
# )
# ->
# ( ds::Declaration
# mld::Package
# mld::Package_Expression
# tro::Typerstore
# )
#
fun type_package'
(
raw::PACKAGE_DEFINITION declaration: raw::Package_Expression,
symbolmapstack: syx::Symbolmapstack,
typerstore: mld::Typerstore,
source_code_region: lnd::Source_Code_Region
)
:
( ds::Declaration, # result_declaration
mld::Package, # result_package
mld::Package_Expression, # result_package_expression
tro::Typerstore
)
=>
{ # We wind up here for vanilla package declarations.
if_debugging_say "type_package'[PACKAGE_DEFINITION] [type-package-language-g.pkg]";
# We enter a new module path context
# whenever we enter a PACKAGE_DEFINITION:
#
stamppath_context'
=
spc::enter_open (
stamppath_context,
module_stamp_v
);
my ( abstract_declaration: ds::Declaration,
symbolmapstack': syx::Symbolmapstack,
module_declaration: Module_Declaration,
typerstore': Typerstore
)
=
type_declaration'
(
declaration: raw::Declaration,
symbolmapstack: syx::Symbolmapstack,
typerstore,
enter_package
syntactic_typechecking_context,
TRUE, # toplevel
stamppath_context',
inverse_path,
source_code_region,
per_compile_stuff
);
if_debugging_say "typecheck[PACKAGE_DEFINITION]: type_declaration' done --type-package-language-g.pkg";
if_debugging_say "type_package'[PACKAGE_DEFINITION]: calling extract_symbolmapstack_contents... --type-package-language-g.pkg";
my ( api_elements: List( (symbol::Symbol, mld::Api_Element ) ),
typerstore'': mld::Typerstore,
module_declarations: List( Module_Declaration ),
symbolmapstack_entries: List( symbolmapstack_entry::Symbolmapstack_Entry ),
contains_generic: Bool
)
=
extract_symbolmapstack_contents (
symbolmapstack',
stamppath_context',
syntactic_typechecking_context,
per_compile_stuff
);
if_debugging_say "type_package'[PACKAGE_DEFINITION]: extract_symbolmapstack_contents done [type-package-language-g.pkg]";
my ( typerstore__local,
module_declaration__local
)
=
case syntactic_typechecking_context
trj::IN_GENERIC _
=>
( tro::mark (make_fresh_stamp, tro::atop (typerstore'', typerstore')),
module_declaration_sequence (module_declaration ! module_declarations)
);
_ => (typerstore'', module_declaration);
esac;
package_expression
=
PACKAGE {
stamp => mld::MAKE_STAMP,
module_declaration
=>
module_declaration__local
};
result_package
=
mld::A_PACKAGE {
an_api,
typechecked_package,
varhome,
inlining_data
}
where
symbols = map #1 api_elements;
an_api
=
mld::API {
stamp => make_fresh_stamp (),
property_list => property_list::make_property_list (),
api_elements,
symbols,
name => NULL,
closed => FALSE,
type_sharing => NIL,
stub => NULL,
contains_generic,
package_sharing => NIL
};
typechecked_package
=
{ stamp => make_fresh_stamp(), # Generate package stamp
stub => NULL,
property_list => property_list::make_property_list (),
inverse_path,
typerstore
=>
tro::mark (
make_fresh_stamp,
tro::atop (
typerstore__local,
typerstore
)
)
};
varhome = vh::named_varhome (temp_package_id, make_var);
inlining_data
=
id::LIST (map mj::extract_inlining_data symbolmapstack_entries);
end;
result_declaration
=
ds::PACKAGE_DECLARATIONS
[
ds::NAMED_PACKAGE
{
name_symbol => temp_package_id,
a_package => result_package,
definition
=> # body
ds::PACKAGE_LET {
declaration => abstract_declaration,
expression => ds::PACKAGE_DEFINITION symbolmapstack_entries
}
}
];
if_debugging_say "type_package'[PACKAGE_DEFINITION] [type-package-language-g.pkg]";
( result_declaration: ds::Declaration,
result_package: mld::Package,
package_expression: mld::Package_Expression,
tro::empty
);
};
type_package'
( raw::CALL_OF_GENERIC (symbol_path, args),
symbolmapstack,
typerstore,
source_code_region
)
=>
{ package_expression'
=
raw::LET_IN_PACKAGE
(
raw::PACKAGE_DECLARATIONS
[
raw::NAMED_PACKAGE
{
name_symbol => return_id,
constraint => raw::NO_PACKAGE_CAST,
definition => raw::INTERNAL_CALL_OF_GENERIC (symbol_path, args),
kind => raw::PLAIN_PACKAGE
}
],
raw::PACKAGE_BY_NAME ( [ return_id, result_id ] )
);
type_package' ( package_expression',
symbolmapstack,
typerstore,
source_code_region
);
};
type_package'
(
raw::INTERNAL_CALL_OF_GENERIC (symbol_path, [ (arg, b) ] ),
symbolmapstack,
typerstore,
source_code_region
)
=>
{ if_debugging_say "type_package'[CALL_OF_GENERIC-one] [type-package-language-g.pkg]";
a_generic
=
fst::find_generic_via_symbol_path (symbolmapstack, syp::SYMBOL_PATH symbol_path, error_fn source_code_region);
if_debugging_say "type_package'[CALL_OF_GENERIC-one]: generic lookup done type-package-language-g.pkg";
show_generic ("type_package'[CALL_OF_GENERIC]: generic ", a_generic, symbolmapstack);
rstamp = make_fresh_stamp (); # module_stamp for the uncoerced argument
my ( arg_declaration: ds::Declaration,
arg_package: mld::Package,
arg_expression: mld::Package_Expression,
arg_dee
)
=
type_package (
arg, # package body to typecheck
NULL, # name_or_null
symbolmapstack,
typerstore,
syntactic_typechecking_context,
stamppath_context,
THE rstamp,
ip::INVERSE_PATH [],
source_code_region,
per_compile_stuff
);
if_debugging_say "type_package'[CALL_OF_GENERIC-one]: typecheck arg done [type-package-language-g.pkg]";
if_debugging_show_package ("type_package'[CALL_OF_GENERIC-one]: arg package: [type-package-language-g.pkg]", arg_package, symbolmapstack);
case (a_generic, arg_package)
#
( (mld::ERRONEOUS_GENERIC, _)
| (_, mld::ERRONEOUS_PACKAGE)
)
=>
{ if_debugging_say "type_package'[CALL_OF_GENERIC-one]: error generic or arg [type-package-language-g.pkg]";
( ds::SEQUENTIAL_DECLARATIONS [],
mld::ERRONEOUS_PACKAGE,
mld::CONSTANT_PACKAGE (mld::bogus_typechecked_package),
tro::empty
);
};
( mld::GENERIC { typechecked_generic, ... },
mld::A_PACKAGE { typechecked_package => arg_typechecked_package, ... }
)
=>
{ result_dee
=
tro::mark (make_fresh_stamp, tro::set (arg_dee, rstamp, mld::PACKAGE_ENTRY arg_typechecked_package));
# the argument package should be bound to rstamp
generic_expression
=
case (spc::find_stamppath_for_generic
(
stamppath_context,
mj::genericstamp_of a_generic
) )
THE stamppath => VARIABLE_GENERIC stamppath;
NULL => CONSTANT_GENERIC typechecked_generic;
esac;
my { result_declaration, result_package, result_expression }
=
am::apply_generic
{
module_stamp_or_null
=>
THE rstamp,
stamppath_context
=>
spc::enter_open
( stamppath_context,
module_stamp_v
),
a_generic,
generic_expression,
arg_package,
arg_expression,
debruijn_depth,
symbolmapstack,
inverse_path,
source_code_region,
per_compile_stuff
};
if_debugging_say "type_package'[CALL_OF_GENERIC-one]: apply_generic done [type-package-language-g.pkg]";
if_debugging_show_package("type_package'[CALL_OF_GENERIC-one]: result: [type-package-language-g.pkg]", result_package, symbolmapstack);
if_debugging_say "type_package'[CALL_OF_GENERIC-one] [type-package-language-g.pkg]";
( ds::SEQUENTIAL_DECLARATIONS [ arg_declaration, result_declaration ]: ds::Declaration,
result_package: mld::Package,
result_expression: mld::Package_Expression,
result_dee
);
};
_ => bug "INTERNAL_CALL_OF_GENERIC: one arg";
esac;
}; # INTERNAL_CALL_OF_GENERIC - one arg
type_package'
( raw::INTERNAL_CALL_OF_GENERIC (symbol_path, arg ! arglist),
symbolmapstack,
typerstore,
source_code_region
)
=>
{ if_debugging_say "type_package':[CALL_OF_GENERIC-many] [type-package-language-g.pkg]";
#
package_expression'
=
raw::LET_IN_PACKAGE
(
raw::PACKAGE_DECLARATIONS
[
raw::NAMED_PACKAGE
{
name_symbol => hidden_id,
constraint => raw::NO_PACKAGE_CAST,
definition => raw::INTERNAL_CALL_OF_GENERIC (symbol_path, [arg]),
kind => raw::PLAIN_PACKAGE
}
],
raw::INTERNAL_CALL_OF_GENERIC ( [ hidden_id, generic_id ], arglist)
);
type_package' (
package_expression',
symbolmapstack,
typerstore,
source_code_region
);
}; # INTERNAL_CALL_OF_GENERIC - multiple args
type_package' (raw::INTERNAL_CALL_OF_GENERIC (symbol_path, []), symbolmapstack, typerstore, source_code_region)
=>
bug "type_package::INTERNAL_CALL_OF_GENERIC -- empty arg list";
type_package'
( raw::PACKAGE_BY_NAME path,
symbolmapstack,
typerstore,
source_code_region
)
=>
{ if_debugging_say "type_package'[PACKAGE_BY_NAME] [type-package-language-g.pkg]";
#
a_package = fst::find_package_via_symbol_path (symbolmapstack, syp::SYMBOL_PATH path, error_fn source_code_region);
# if_debugging_show_package("type_package'[PACKAGE_BY_NAME]: package: [type-package-language-g.pkg]", a_package, symbolmapstack);
typechecked_package
=
case a_package
A_PACKAGE { typechecked_package, ... } => typechecked_package;
_ => mld::bogus_typechecked_package; # error recovery
esac;
result_expression
=
case a_package
A_PACKAGE _
=>
# if_debugging_say "type_package'[PACKAGE_BY_NAME]: result_expression/A_PACKAGE [type-package-language-g.pkg]";
#
case (spc::find_stamppath_for_package
(
stamppath_context,
mj::packagestamp_of a_package
) )
THE stamppath => mld::VARIABLE_PACKAGE stamppath;
NULL => mld::CONSTANT_PACKAGE typechecked_package;
esac;
_ => mld::CONSTANT_PACKAGE mld::bogus_typechecked_package; # error recovery
esac;
# if_debugging_say "type_package'[PACKAGE_BY_NAME] [type-package-language-g.pkg]";
( ds::SEQUENTIAL_DECLARATIONS []: ds::Declaration,
a_package: mld::Package,
result_expression: mld::Package_Expression,
tro::empty
);
};
type_package'
( raw::LET_IN_PACKAGE (declaration, a_package),
symbolmapstack,
typerstore,
source_code_region
)
=>
{ if_debugging_say "type_package'[LET_IN_PACKAGE] [type-package-language-g.pkg]";
my ( local_abstract_declaration,
symbolmapstack',
local_module_declaration,
typerstore'
)
=
type_declaration' (
declaration,
symbolmapstack,
typerstore,
syntactic_typechecking_context,
TRUE, # toplevel
stamppath_context,
inverse_path,
source_code_region,
per_compile_stuff
);
# top = TRUE: Don't allow nongeneralized type variables
# in local declarations because of bug 905/952. This is
# stricter than necessary. Could allow top = FALSE
# if the body package contains no generics. To make the
# condition more precise, have to synthesize a boolean
# attribute indicating presence of generics [dbm]
# DAVE? what context to use for the local declarations?
# perhaps should null bind_context as for generic body?
# perhaps it doesn't matter because of relativization
# and the fact that local typerstore can't be referred
# to from outside. XXX BUGGO FIXME
if_debugging_say "type_package'[LET_IN_PACKAGE]: local type_declaration' done [type-package-language-g.pkg]";
my ( body_abstract_declaration: ds::Declaration,
body_package: mld::Package,
body_expression: mld::Package_Expression,
body_dee
)
=
type_package' (
a_package,
syx::atop (symbolmapstack', symbolmapstack),
tro::atop (typerstore', typerstore),
source_code_region
);
result_declaration = ds::SEQUENTIAL_DECLARATIONS [local_abstract_declaration, body_abstract_declaration];
result_expression = mld::PACKAGE_LET { declaration => local_module_declaration, expression => body_expression };
if_debugging_say "type_package'[LET_IN_PACKAGE]: typecheck body pkg done [type-package-language-g.pkg]";
( result_declaration: ds::Declaration,
body_package: mld::Package,
result_expression: mld::Package_Expression,
tro::mark
( make_fresh_stamp,
tro::atop_sp (body_dee, typerstore')
)
);
};
type_package'
( raw::PACKAGE_CAST (constrained_package, api_constraint),
symbolmapstack,
typerstore,
source_code_region
)
=>
{ if_debugging_say "type_package'[PACKAGE_CAST]: TOP [type-package-language-g.pkg]";
#
my ( module_stamp_v,
module_stamp_or_null
)
=
case api_constraint
#
raw::NO_PACKAGE_CAST
=>
(module_stamp_v, NULL);
_ => { nentv = THE (make_fresh_stamp());
(nentv, nentv);
};
esac;
if_debugging_say "type_package'[PACKAGE_CAST]: above call to type_package [type-package-language-g.pkg]";
# Typecheck the constrained package by itself:
#
my ( abstract_pkg_declaration: ds::Declaration,
a_package: mld::Package,
expression: mld::Package_Expression,
typerstore_additions
)
=
type_package (
constrained_package, # package body to typecheck
NULL, # name_or_null.
symbolmapstack,
typerstore,
syntactic_typechecking_context,
stamppath_context,
module_stamp_v,
inverse_path,
source_code_region,
per_compile_stuff
);
if_debugging_say "type_package'[PACKAGE_CAST]: above call to type_api [type-package-language-g.pkg]";
# Typecheck the constraining api by itself:
#
my ( constraining_api_or_null,
package_cast
)
=
{ fun type_api api_expression
=
ta::type_api {
api_expression,
symbolmapstack,
name_or_null => NULL,
typerstore,
stamppath_context,
source_code_region,
per_compile_stuff
};
if_debugging_say "type_package'[PACKAGE_CAST]: above possible call to type_api [type-package-language-g.pkg]";
my ( constraining_api_or_null: Null_Or( mld::Api ),
package_cast: Package_Cast
)
=
case api_constraint
raw::WEAK_PACKAGE_CAST an_api => (THE (type_api an_api), WEAK_PACKAGE_CAST );
raw::PARTIAL_PACKAGE_CAST an_api => (THE (type_api an_api), PARTIAL_PACKAGE_CAST );
raw::STRONG_PACKAGE_CAST an_api => (THE (type_api an_api), STRONG_PACKAGE_CAST );
_ => (NULL, WEAK_PACKAGE_CAST );
esac;
if_debugging_say "type_package'[PACKAGE_CAST]: below possible call to type_api [type-package-language-g.pkg]";
( constraining_api_or_null,
package_cast
);
};
if *debugging
case package_cast
WEAK_PACKAGE_CAST => print "--type_package'[PACKAGE_CAST] above hack: This is a WEAK cast.\n";
STRONG_PACKAGE_CAST => print "--type_package'[PACKAGE_CAST] above hack: This is a STRONG cast.\n";
PARTIAL_PACKAGE_CAST => print "--type_package'[PACKAGE_CAST] above hack: This is a PARTIAL cast.\n";
esac;
fi;
# If this is a PARTIAL_PACKAGE_CAST,
# hack the constraining api to reduce
# it to the STRONG_PACKAGE_CAST case:
#
my (constraining_api_or_null, package_cast, symbolmapstack)
=
maybe_extend_api_to_cover_package (constraining_api_or_null, package_cast, a_package, symbolmapstack);
if *debugging
case package_cast
WEAK_PACKAGE_CAST => print "--type_package'[PACKAGE_CAST] below hack: This is a WEAK cast.\n";
STRONG_PACKAGE_CAST => print "--type_package'[PACKAGE_CAST] below hack: This is a STRONG cast.\n";
PARTIAL_PACKAGE_CAST => print "--type_package'[PACKAGE_CAST] below hack: This is a PARTIAL cast.\n";
esac;
fi;
if_debugging_say "type_package'[PACKAGE_CAST]: below call to type_package [type-package-language-g.pkg]";
unparse_deep_declaration ("type_package'[PACKAGE_CAST]: unparsing abtract_pkg_declaration deep syntax: [type-package-language-g.pkg]", abstract_pkg_declaration, symbolmapstack);
if_debugging_show_package("type_package'[PACKAGE_CAST]: a_package: [type-package-language-g.pkg]", a_package, symbolmapstack);
result_dee
=
case api_constraint
#
raw::NO_PACKAGE_CAST
=>
typerstore_additions;
_ => case module_stamp_or_null
#
THE tmpev
=>
{ typechecked_package
=
case a_package
#
mld::A_PACKAGE { typechecked_package, ... }
=>
typechecked_package;
_ => mld::bogus_typechecked_package;
esac;
tro::set (typerstore_additions, tmpev, mld::PACKAGE_ENTRY typechecked_package);
};
_ => bug "unexpected api_constraint while typechecking constrained package";
esac;
esac;
if_debugging_say "type_package'[PACKAGE_CAST]: above possible call to type_constrained_package [type-package-language-g.pkg]";
# Now typecheck the constrained package
# against the constraining api:
#
my ( result_declaration: ds::Declaration,
result_package: mld::Package,
result_expression: mld::Package_Expression
)
=
case constraining_api_or_null
#
NULL => { if (package_cast != WEAK_PACKAGE_CAST)
error_fn
source_code_region
err::ERROR
"missing api in abstraction declaration"
err::null_error_body;
fi;
(abstract_pkg_declaration, a_package, expression);
};
THE constraining_api
=>
type_constrained_package (
a_package: mld::Package, # Package to be constrained by api.
package_cast: Package_Cast, # How to apply API -- strong/weak/partial cast.
constraining_api: mld::Api, # Api to constrain package.
abstract_pkg_declaration: ds::Declaration,
expression: mld::Package_Expression,
module_stamp_or_null,
debruijn_depth,
typerstore,
inverse_path,
symbolmapstack,
source_code_region,
per_compile_stuff
);
esac;
if_debugging_say "type_package'[PACKAGE_CAST]: below possible call to type_constrained_package -- DONE [type-package-language-g.pkg]";
unparse_deep_declaration ("type_package'[PACKAGE_CAST]: unparsing result_declaration deep syntax: [type-package-language-g.pkg]", result_declaration, symbolmapstack);
if_debugging_show_package("type_package'[PACKAGE_CAST]: package: [type-package-language-g.pkg]", result_package, symbolmapstack);
( result_declaration: ds::Declaration,
result_package: mld::Package,
result_expression: mld::Package_Expression,
result_dee
);
};
type_package' (
raw::SOURCE_CODE_REGION_FOR_PACKAGE (
package_expression',
source_code_region'
),
symbolmapstack,
typerstore,
source_code_region
)
=>
{ my ( result_declaration: ds::Declaration,
a_package: mld::Package,
result_expression: mld::Package_Expression,
result_dee
)
=
type_package' (
package_expression',
symbolmapstack,
typerstore,
source_code_region'
);
( ds::SOURCE_CODE_REGION_FOR_DECLARATION (result_declaration, source_code_region'): ds::Declaration,
a_package: mld::Package,
result_expression: mld::Package_Expression,
result_dee
);
};
end; # fun type_package'
my ( result_declaration: ds::Declaration,
result_package: mld::Package,
result_expression: mld::Package_Expression,
result_dee
)
=
type_package' (
package_body_to_typecheck: raw::Package_Expression,
symbolmapstack: syx::Symbolmapstack,
typerstore: mld::Typerstore,
source_code_region: lnd::Source_Code_Region
);
if_debugging_say "type_package [type-package-language-g.pkg]";
( result_declaration: ds::Declaration,
result_package: mld::Package,
result_expression: mld::Package_Expression,
result_dee
);
} # function type_package
# type_generic: Typecheck a generic, possibly with api constraint:
#
also
fun type_generic (
generic_expression: raw::Generic_Expression,
curried: Bool,
name: sy::Symbol,
symbolmapstack: syx::Symbolmapstack,
typerstore: mld::Typerstore,
syntactic_typechecking_context: trj::Syntactic_Typechecking_Context,
stamppath_context: spc::Context,
inverse_path: ip::Inverse_Path,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff as { issue_highcode_codetemp => make_var, make_fresh_stamp, error_fn, ... }: trj::Per_Compile_Stuff
)
:
( ds::Declaration,
mld::Generic_Expression,
mld::Generic,
tro::Typerstore
)
=
{ debruijn_depth
=
case syntactic_typechecking_context
#
trj::IN_GENERIC { debruijn_depth, ... } => debruijn_depth;
_ => di::top;
esac;
if_debugging_say ("type_generic: [type-package-language-g.pkg] " + (sy::name name));
case generic_expression
#
raw::GENERIC_BY_NAME (symbol_path, constraint_expression)
=>
{ a_generic = fst::find_generic_via_symbol_path (symbolmapstack, syp::SYMBOL_PATH symbol_path, error_fn source_code_region);
#
case a_generic
#
ERRONEOUS_GENERIC
=>
( ds::SEQUENTIAL_DECLARATIONS [],
CONSTANT_GENERIC (mld::bogus_typechecked_generic),
a_generic,
tro::empty
);
_ =>
{ uncoerced_expression
=
case (spc::find_stamppath_for_generic (stamppath_context, mj::genericstamp_of a_generic))
#
THE stamppath
=>
VARIABLE_GENERIC stamppath;
NULL => { typechecked_package
=
case a_generic
#
GENERIC ft => ft.typechecked_generic;
_ => mld::bogus_typechecked_generic;
esac;
CONSTANT_GENERIC typechecked_package;
};
esac;
case constraint_expression
#
raw::NO_PACKAGE_CAST
=>
( ds::SEQUENTIAL_DECLARATIONS [],
uncoerced_expression,
a_generic,
tro::empty
);
raw::WEAK_PACKAGE_CAST raw_generic_api
=>
{ name_or_null = THE (anonymous_generic_api_id);
#
a_generic_api
=
ta::type_generic_api {
generic_api_expression => raw_generic_api,
name_or_null,
symbolmapstack,
typerstore,
stamppath_context,
source_code_region,
per_compile_stuff
};
my { result_declaration, result_generic, result_expression }
=
am::match_generic
{
an_api => a_generic_api,
generic_expression => uncoerced_expression,
a_generic,
debruijn_depth,
typerstore,
inverse_path,
symbolmapstack,
source_code_region,
per_compile_stuff
};
( result_declaration,
result_expression,
result_generic,
tro::empty
);
};
raw::PARTIAL_PACKAGE_CAST raw_generic_api
=>
bug "'partial' generic constraints not implemented"; # XXX BUGGO FIXME
raw::STRONG_PACKAGE_CAST raw_generic_api
=>
bug "Opaque generic constraints not implemented"; # XXX BUGGO FIXME
esac;
};
esac;
};
raw::LET_IN_GENERIC (declaration, a_generic)
=>
{ if_debugging_say "typecheck[LET_IN_GENERIC] [type-package-language-g.pkg]";
my ( local_abstract_declaration,
symbolmapstack',
local_module_declaration,
typerstore'
)
=
type_declaration' (
declaration,
symbolmapstack,
typerstore,
syntactic_typechecking_context,
TRUE, # top
stamppath_context,
inverse_path,
source_code_region,
per_compile_stuff
);
# top = TRUE: don't allow nongeneralized type variables
# in local declarations because of bug 905/952 [dbm]
if_debugging_say "typecheck[LET_IN_GENERIC]: local type_declaration' done [type-package-language-g.pkg]";
my ( body_abstract_declaration,
body_expression,
body_g,
body_dee
)
=
type_generic
( a_generic,
FALSE, # Curried
name,
syx::atop (symbolmapstack', symbolmapstack),
tro::atop (typerstore', typerstore),
syntactic_typechecking_context,
stamppath_context,
inverse_path,
source_code_region,
per_compile_stuff
);
result_deep_syntax_tree = ds::SEQUENTIAL_DECLARATIONS [local_abstract_declaration, body_abstract_declaration];
result_expression = mld::LET_GENERIC (local_module_declaration, body_expression);
result_typerstore = tro::mark (make_fresh_stamp, tro::atop_sp (body_dee, typerstore'));
( result_deep_syntax_tree,
result_expression,
body_g,
result_typerstore
);
};
raw::CONSTRAINED_CALL_OF_GENERIC (symbol_path, arglist, constraint)
=>
{ generic_expression'
=
raw::LET_IN_GENERIC (
raw::PACKAGE_DECLARATIONS [
raw::NAMED_PACKAGE {
name_symbol => hidden_id,
constraint => raw::NO_PACKAGE_CAST,
definition => raw::INTERNAL_CALL_OF_GENERIC (symbol_path, arglist),
kind => raw::PLAIN_PACKAGE
}
],
raw::GENERIC_BY_NAME (
[ hidden_id, generic_id ],
constraint
)
);
type_generic
( generic_expression',
FALSE,
name,
symbolmapstack,
typerstore,
syntactic_typechecking_context,
stamppath_context,
inverse_path,
source_code_region,
per_compile_stuff
);
};
raw::GENERIC_DEFINITION { parameters => [ (parameter_name_or_null, param_sig_expression) ], body, constraint }
=>
{ if_debugging_say "type_generic[GENERIC_DEFINITION] [type-package-language-g.pkg]";
#
body = if curried
body;
else
raw::PACKAGE_DEFINITION (
raw::PACKAGE_DECLARATIONS [
raw::NAMED_PACKAGE {
name_symbol => result_id,
definition => body,
constraint,
kind => raw::PLAIN_PACKAGE
}
]
);
fi;
constraint
=
if curried constraint;
else raw::NO_PACKAGE_CAST;
fi;
my (flex, debruijn_depth)
=
case syntactic_typechecking_context
#
trj::IN_GENERIC { flex, debruijn_depth }
=>
(flex, debruijn_depth);
_ => # Entering generic for first time.
{ base = make_fresh_stamp();
#
fun h s
=
case (stamp::compare (base, s))
LESS => TRUE;
_ => FALSE;
esac;
(h, di::top);
};
esac;
parameter_name
=
case parameter_name_or_null
THE n => n;
NULL => param_id;
esac;
param_typechecked_package_variable
=
make_fresh_stamp ();
if_debugging_say ( "type_generic[GENERIC_DEFINITION]: param_macro_expansion_variable = "
+ mp::module_stamp_to_string param_typechecked_package_variable
+ " [type-package-language-g.pkg]"
);
param_sig
=
ta::type_api {
api_expression => param_sig_expression,
name_or_null => NULL,
symbolmapstack,
typerstore,
stamppath_context,
source_code_region,
per_compile_stuff
};
if_debugging_say "type_generic[GENERIC_DEFINITION]: param_sig defined [type-package-language-g.pkg]";
case param_sig
#
ERRONEOUS_API => raise exception err::COMPILE_ERROR; # Bail out -- not attempting to recover
_ => ();
esac;
# Now know that param_sig is defined.
# This creates new stamps, but we don't bother to update the
# epcontext, we do that later through map_paths:
#
my { typechecked_package => param_typechecked_package,
typepaths => param_tps
}
=
ins::do_generic_parameter_api {
an_api => param_sig,
inverse_path => ip::INVERSE_PATH ( case parameter_name_or_null
NULL => [];
_ => [parameter_name];
esac
),
typerstore,
source_code_region,
debruijn_depth,
per_compile_stuff
};
parameter_package
=
{ param_dacc = vh::named_varhome (parameter_name, make_var);
#
mld::A_PACKAGE {
an_api => param_sig,
typechecked_package => param_typechecked_package,
varhome => param_dacc, # "dacc" is probably "dynamic access"
inlining_data => id::NIL
};
};
if_debugging_say "type_generic[GENERIC_DEFINITION]: parameter macro expanded [type-package-language-g.pkg]";
if_debugging_show_package ("type_generic[GENERIC_DEFINITION]: [type-package-language-g.pkg] parameter_package: ", parameter_package, symbolmapstack);
typerstore'
=
tro::mark (
make_fresh_stamp,
tro::set (
typerstore,
param_typechecked_package_variable,
mld::PACKAGE_ENTRY param_typechecked_package
)
);
if_debugging_say "type_generic[GENERIC_DEFINITION]: parameter tro::set [type-package-language-g.pkg]";
symbolmapstack'
=
case parameter_name_or_null
#
NULL => mj::include_package (symbolmapstack, parameter_package);
THE _ => syx::bind (parameter_name, sxe::NAMED_PACKAGE parameter_package, symbolmapstack);
esac;
if_debugging_say "type_generic[GENERIC_DEFINITION]: parameter bound/opened [type-package-language-g.pkg]";
stamppath_context'
=
spc::enter_closed stamppath_context;
# Fill in path_dictionary with paths for elements of parameter_package:
#
map_paths (spc::enter_open (stamppath_context', THE param_typechecked_package_variable), parameter_package, flex);
spc::bind_stamppath
(
stamppath_context',
mj::packagestamp_of parameter_package,
param_typechecked_package_variable
);
if_debugging_say "type_generic[GENERIC_DEFINITION]: stamppath_context initialized [type-package-language-g.pkg]";
# Must typecheck result api before the body is typechecked
# so that stamppath_context' is not changed:
#
my ( module_stamp_v,
constraining_api,
constraining_api_op
)
=
{ fun type_api x
=
ta::type_api {
api_expression => x,
name_or_null => NULL,
symbolmapstack => symbolmapstack',
typerstore => typerstore',
stamppath_context => stamppath_context',
source_code_region,
per_compile_stuff
};
case constraint
#
raw::NO_PACKAGE_CAST => (NULL, NULL, WEAK_PACKAGE_CAST);
raw::WEAK_PACKAGE_CAST an_api => (THE (make_fresh_stamp()), THE (type_api an_api), WEAK_PACKAGE_CAST);
raw::PARTIAL_PACKAGE_CAST an_api => (THE (make_fresh_stamp()), THE (type_api an_api), PARTIAL_PACKAGE_CAST);
raw::STRONG_PACKAGE_CAST an_api => (THE (make_fresh_stamp()), THE (type_api an_api), STRONG_PACKAGE_CAST);
esac;
};
if_debugging_say "type_generic[GENERIC_DEFINITION]: result api typecheckd [type-package-language-g.pkg]";
# Adjust the trj::context value; the debruijn_depth refers to the number
# of enclosing generic abstractions. (ZHONG)
#
debruijn_depth' = di::next debruijn_depth;
context' = trj::IN_GENERIC { flex, debruijn_depth => debruijn_depth' };
# body_dee is discarded here;
# however, it is not discarded
# when generic is applied.
#
my ( body_abstract_declaration,
body_package,
body_expression,
body_dee # "dee" == "delta eleboration environment" I think -- additions to typechecking dictionary.
)
=
type_package (
body,
NULL,
symbolmapstack',
typerstore',
context',
stamppath_context',
module_stamp_v,
ip::INVERSE_PATH [],
source_code_region,
per_compile_stuff
);
if_debugging_say "type_generic[GENERIC_DEFINITION]: body typecheckd [type-package-language-g.pkg]";
if_debugging_show_package("type_generic[GENERIC_DEFINITION]: body_package: [type-package-language-g.pkg]", body_package, symbolmapstack);
# Constrain by result api, on of:
#
#
my ( body_abstract_declaration',
body_package',
body_expression'
)
=
case constraining_api
#
NULL => (body_abstract_declaration, body_package, body_expression);
THE constraining_api'
=>
type_constrained_package (
body_package,
constraining_api_op, # match/edit/cast.
constraining_api',
body_abstract_declaration,
body_expression,
module_stamp_v,
debruijn_depth',
typerstore',
ip::INVERSE_PATH [],
symbolmapstack',
source_code_region,
per_compile_stuff
);
esac;
if_debugging_say "type_generic[GENERIC_DEFINITION]: body constrained [type-package-language-g.pkg]";
generic_expression
=
mld::LAMBDA {
parameter => param_typechecked_package_variable,
body => body_expression'
};
result_generic
=
{ body_sig'
=
case body_package'
#
A_PACKAGE { an_api, ... } => an_api;
_ => ERRONEOUS_API;
esac;
a_generic_api
=
mld::GENERIC_API
{
kind => NULL,
parameter_api => param_sig,
body_api => body_sig',
parameter_variable => param_typechecked_package_variable,
parameter_symbol => parameter_name_or_null
};
typechecked_generic
=
{
stamp => make_fresh_stamp (),
property_list => property_list::make_property_list (),
inverse_path,
#
stub => NULL,
typepath => NULL,
# Closure: Using the old typechecked_package dictionary !! XXX BUGGO FIXME
generic_closure => mld::GENERIC_CLOSURE
{
parameter_module_stamp => param_typechecked_package_variable,
body_package_expression => body_expression',
typerstore
}
};
dacc = vh::named_varhome (name, make_var);
mld::GENERIC { a_generic_api,
typechecked_generic,
varhome => dacc,
inlining_data => id::NIL
};
};
if_debugging_say "type_generic[GENERIC_DEFINITION]: result_generic defined [type-package-language-g.pkg]";
result_declaration
=
{ x = ds::GENERIC_DEFINITION { parameter => parameter_package,
parameter_types => param_tps,
definition => ds::PACKAGE_LET {
declaration => body_abstract_declaration',
expression => ds::PACKAGE_BY_NAME body_package'
}
};
ds::GENERIC_DECLARATIONS [ ds::NAMED_GENERIC { name_symbol => name,
a_generic => result_generic,
definition => x
}
];
};
if_debugging_say "type_generic[GENERIC_DEFINITION] [type-package-language-g.pkg]";
if_debugging_show_package("type_generic[GENERIC_DEFINITION]: parameter_package: [type-package-language-g.pkg] ", parameter_package, symbolmapstack);
(result_declaration, generic_expression, result_generic, tro::empty);
};
raw::GENERIC_DEFINITION { parameters => parameter ! lparam, body, constraint }
=>
{ generic_expression'
=
raw::GENERIC_DEFINITION {
parameters => [ parameter ],
body => raw::PACKAGE_DEFINITION (
raw::GENERIC_DECLARATIONS [
raw::NAMED_GENERIC {
name_symbol => generic_id,
definition => raw::GENERIC_DEFINITION {
parameters => lparam,
body,
constraint
}
}
]
),
constraint => raw::NO_PACKAGE_CAST
};
type_generic
( generic_expression',
TRUE,
name,
symbolmapstack,
typerstore,
syntactic_typechecking_context,
stamppath_context,
inverse_path,
source_code_region,
per_compile_stuff
);
};
raw::GENERIC_DEFINITION { parameters => [], ... }
=>
bug "type_generic";
raw::SOURCE_CODE_REGION_FOR_GENERIC ( generic_expression', source_code_region' )
=>
type_generic
( generic_expression',
curried,
name,
symbolmapstack,
typerstore,
syntactic_typechecking_context,
stamppath_context,
inverse_path,
source_code_region',
per_compile_stuff
);
esac;
} # function type_generic
# type_named_packages: typecheck named packages, with api constraint.
#
also
fun type_named_packages
(
named_packages: List( raw::Named_Package ), # Declarations being typechecked.
given_symbolmapstack: syx::Symbolmapstack, # Symbol table containing info from all .compiled files we depend on.
typerstore0: mld::Typerstore,
syntactic_typechecking_context: trj::Syntactic_Typechecking_Context,
stamppath_context: spc::Context,
inverse_path: ip::Inverse_Path,
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, # Typechecked version of named_packages.
syx::Symbolmapstack, # Contains (only) stuff from named_packages.
mld::Module_Declaration,
Typerstore
)
=
{ debruijn_depth
=
case syntactic_typechecking_context
#
trj::IN_GENERIC { debruijn_depth, ... } => debruijn_depth;
_ => di::top;
esac;
if_debugging_say "type_named_packages [type-package-language-g.pkg]";
( loop ( named_packages,
[], # declarations accumulate here.
syx::empty, # Symbol table to fill out.
[], # generics accumulate here.
tro::empty # Generics dictionary to fill out.
)
except
tro::UNBOUND
=
{ if_debugging_say
( "@@type_named_packages0 "
);
raise exception tro::UNBOUND;
}
)
where
fun loop ([], declarations, symbolmapstack', module_declarations, typerstore)
=>
{
# We've finished processing our input
# list of named packages (first arg)
# so it is time to wrap up and return
# our results:
if_debugging_say "list exhausted/AAA in loop() in type_named_packages src/lib/compiler/front/typer/main/type-package-language-g.pkg";
result_declaration
=
ds::PACKAGE_DECLARATIONS (reverse declarations);
if_debugging_say "list exhausted/BBB in loop() in type_named_packages src/lib/compiler/front/typer/main/type-package-language-g.pkg";
module_declaration
=
case module_declarations
[] => mld::EMPTY_GENERIC_EVALUATION_DECLARATION;
_ => module_declaration_sequence (reverse module_declarations);
esac;
if_debugging_say "list exhausted/CCC in loop() in type_named_packages src/lib/compiler/front/typer/main/type-package-language-g.pkg";
( result_declaration, # Typechecked deep-syntax version of named_packages.
symbolmapstack', # Contains (only) stuff from named_packages.
module_declaration,
typerstore
);
};
# Peel one named package off our input list
# (first arg), process it, accumulate the
# results in our remaining args, and loop:
#
loop
( named_package ! remaining_named_packages, # Input list of raw-syntax named packages.
declarations, # Output list of typechecked deep-syntax packages.
symbolmapstack', # Contains (only) stuff from input named_packages list.
module_declarations,
typerstore
)
=>
{
if_debugging_say "list NOT exhausted/AAA in loop() in type_named_packages in src/lib/compiler/front/typer/main/type-package-language-g.pkg";
# Discard any source code region info nodes,
# after noting the current source code region:
#
my ( name: symbol::Symbol,
constraint: raw::Package_Cast( raw::Api_Expression ),
package_body_to_typecheck: raw::Package_Expression,
kind: raw::Package_Kind,
source_code_region'
)
=
case (strip_source_code_region_data_from_named_package (named_package, source_code_region))
(raw::NAMED_PACKAGE { name_symbol, constraint, definition, kind }, region)
=>
(name_symbol, constraint, definition, kind, region);
_ => bug "non package namings in type_named_packages";
esac;
if_debugging_say ("package " + sy::name name + "list NOT exhausted/BBB in loop() in type_named_packages in src/lib/compiler/front/typer/main/type-package-language-g.pkg");
# Do OOP syntax expansion:
#
package_body_to_typecheck
=
case kind
raw::PLAIN_PACKAGE
=>
package_body_to_typecheck;
raw::CLASS_PACKAGE
=>
expand_oop_syntax_in_package_expression
(
name,
package_body_to_typecheck,
syx::atop
( symbolmapstack', # Contains (only) stuff from input named_packages list.
given_symbolmapstack # Symbol table containing info from all .compiled files we depend on.
),
source_code_region',
per_compile_stuff
);
raw::CLASS2_PACKAGE
=>
expand_oop_syntax_in_package_expression2
(
name,
package_body_to_typecheck,
syx::atop
( symbolmapstack', # Contains (only) stuff from input named_packages list.
given_symbolmapstack # Symbol table containing info from all .compiled files we depend on.
),
source_code_region',
per_compile_stuff
);
esac;
# Make a typechecked_package stamp
# for the current package declaration:
#
rstamp = make_fresh_stamp (); # We don't always have to do this
if_debugging_say ("package " + sy::name name + "list NOT exhausted/CCC in loop() in type_named_packages in src/lib/compiler/front/typer/main/type-package-language-g.pkg");
# module_stamp_v is the context for evaluating
# the right-hand-side of a package declaration:
#
my ( module_stamp_v,
module_stamp_or_null,
constraining_api_or_null,
package_cast
)
=
{ fun type_api api_expression
=
{
if_debugging_say ("calling ta::type_api in package " + sy::name name
+ " list NOT exhausted/DDD in type_api loop() in type_named_packages in src/lib/compiler/front/typer/main/type-package-language-g.pkg");
constraint_api
=
ta::type_api
{
api_expression, # This is what we're typechecking.
name_or_null => NULL,
symbolmapstack => given_symbolmapstack, # Symbol table containing info from all .compiled files we depend on.
typerstore => typerstore0,
stamppath_context,
source_code_region,
per_compile_stuff
};
if_debugging_say ("back from ta::type_api in package " + sy::name name
+ " list NOT exhausted/EEE in type_api loop() in type_named_packages in src/lib/compiler/front/typer/main/type-package-language-g.pkg");
# If constraining api didn't typecheck,
# just pretend it didn't exist:
#
if_debugging_say ("constraining api " + case constraint_api ERRONEOUS_API => "did NOT"; _ => "DID"; esac
+ " typecheck in package " + sy::name name
+ "list NOT exhausted/FFF in type_api loop() in type_named_packages in src/lib/compiler/front/typer/main/type-package-language-g.pkg");
case constraint_api
#
ERRONEOUS_API => NULL;
_ => THE constraint_api;
esac;
};
if_debugging_say ("Doing 'constraint' case src/lib/compiler/front/typer/main/type-package-language-g.pkg: --type_named_packages: \n");
my ( constraining_api_or_null,
package_cast
)
=
case constraint
#
raw::WEAK_PACKAGE_CAST api_expression
=>
{ if_debugging_say "type_named_packages[WEAK_PACKAGE_CAST]: calling type_api [type-package-language-g.pkg]\n";
( type_api api_expression,
WEAK_PACKAGE_CAST
);
};
raw::PARTIAL_PACKAGE_CAST api_expression
=>
{ if_debugging_say "type_named_packages[PARTIAL_PACKAGE_CAST]: calling type_api [type-package-language-g.pkg]\n";
case (type_api api_expression)
NULL => (NULL, WEAK_PACKAGE_CAST);
other => (other, PARTIAL_PACKAGE_CAST);
esac;
};
raw::STRONG_PACKAGE_CAST api_expression
=>
{ if_debugging_say "type_named_packages[STRONG_PACKAGE_CAST]: calling type_api [type-package-language-g.pkg]\n";
case (type_api api_expression)
NULL => (NULL, WEAK_PACKAGE_CAST);
other => (other, STRONG_PACKAGE_CAST);
esac;
};
_ =>
{ if_debugging_say "type_named_packages[(NULL api constraint)]: not calling type_api [type-package-language-g.pkg]\n";
(NULL, WEAK_PACKAGE_CAST);
};
esac;
if_debugging_say "type_named_packages: DONE 'constraint' case [type-package-language-g.pkg]\n";
# The temporary anonymous package:
#
my ( module_stamp_v,
module_stamp_or_null
)
=
case constraining_api_or_null
#
NULL => (rstamp, NULL);
_ => { new_module_stamp = make_fresh_stamp ();
( new_module_stamp,
THE new_module_stamp
);
};
esac;
(module_stamp_v, module_stamp_or_null, constraining_api_or_null, package_cast);
};
if_debugging_say "type_named_packages: typechecking package body [type-package-language-g.pkg]\n";
# Typecheck the package body:
#
my ( abstract_package_declaration: ds::Declaration,
a_package: mld::Package,
package_expression: mld::Package_Expression,
typerstore_additions: tro::Typerstore
)
=
type_package
(
package_body_to_typecheck,
THE name,
given_symbolmapstack, # Symbol table containing info from all .compiled files we depend on.
typerstore0,
syntactic_typechecking_context,
stamppath_context,
THE module_stamp_v,
ip::extend (inverse_path, name),
source_code_region',
per_compile_stuff
);
if_debugging_say "type_named_packages: DONE typechecking package body. [type-package-language-g.pkg]\n";
# Check for partially applied curried generic
#
a_package
=
if (sy::eq (name, return_id))
#
# a_package should be generic application wrapper package
# with single package component "result_package"
#
if case a_package
#
ERRONEOUS_PACKAGE => TRUE;
_ => case (mj::get_package_symbols a_package)
#
[symbol] => sy::eq (symbol, result_id);
_ => FALSE;
esac;
esac
a_package;
else
error_fn
source_code_region'
err::ERROR
( "package "
+ sy::name (ip::last inverse_path)
+ " defined by partially applied generic"
)
err::null_error_body;
ERRONEOUS_PACKAGE;
fi;
else
a_package;
fi;
if_debugging_say "type_named_packages: type_package done [type-package-language-g.pkg]";
unparse_deep_declaration ("type_named_packages after body typechecking: unparsing abstract_package_declaration deep syntax: [type-package-language-g.pkg] ",
abstract_package_declaration, symbolmapstack');
if_debugging_show_package("unconstrained package: [type-package-language-g.pkg] ", a_package, symbolmapstack');
# If this is a PARTIAL_PACKAGE_CAST,
# hack the constraining api to reduce
# it to the STRONG_PACKAGE_CAST case:
#
if_debugging_say "type_named_packages: calling maybe_extend_api_to_cover_package. [type-package-language-g.pkg]\n";
my ( constraining_api_or_null,
package_cast,
symbolmapstack' # Contains (only) stuff from input named_packages list.
)
=
maybe_extend_api_to_cover_package
( constraining_api_or_null,
package_cast,
a_package,
symbolmapstack'
);
if_debugging_say "type_named_packages: DONE calling maybe_extend_api_to_cover_package. [type-package-language-g.pkg]\n";
# Typecheck an api match.
# Notice that we did introduce stamps
# during the abstraction matching, but
# that these stamps are always visible,
# thus will always be caught by the post
# api-matching "map_paths" function call:
#
my ( result_declaration,
result_package,
result_package_expression
)
=
case constraining_api_or_null
#
NULL
=>
{ case package_cast
#
WEAK_PACKAGE_CAST
=>
();
PARTIAL_PACKAGE_CAST
=>
( error_fn
source_code_region'
err::ERROR
"missing api in partial package cast declaration"
err::null_error_body
);
STRONG_PACKAGE_CAST
=>
( error_fn
source_code_region'
err::ERROR
"missing api in strong package cast declaration"
err::null_error_body
);
esac;
if_debugging_say "type_named_packages: NOT calling type_constrained_package [type-package-language-g.pkg] ";
( abstract_package_declaration,
a_package,
package_expression
);
};
THE constraint_api
=>
{
if_debugging_say "type_named_packages: calling type_constrained_package [type-package-language-g.pkg] ";
type_constrained_package
(
a_package,
package_cast,
constraint_api,
abstract_package_declaration,
package_expression,
module_stamp_or_null,
debruijn_depth,
typerstore0,
ip::INVERSE_PATH [ name ],
syx::atop
( symbolmapstack', # Contains (only) stuff from input named_packages list.
given_symbolmapstack # Symbol table containing info from all .compiled files we depend on.
),
source_code_region,
per_compile_stuff
);
};
esac;
if_debugging_say "type_named_packages: now past type_constrained_package call point. [type-package-language-g.pkg]";
typerstore_additions
=
case (module_stamp_or_null, constraining_api_or_null)
#
(NULL, NULL)
=>
typerstore_additions;
(THE module_stamp, THE _)
=>
case a_package
#
mld::A_PACKAGE { typechecked_package, ... }
=>
tro::set (
typerstore_additions,
module_stamp,
mld::PACKAGE_ENTRY typechecked_package
);
_ => tro::set (
typerstore_additions,
module_stamp,
mld::PACKAGE_ENTRY mld::bogus_typechecked_package
);
esac;
_ => bug "unexpected case in type_named_packages: macro_expansion_dictionary_additions";
esac;
if_debugging_say "type_named_packages: constrain done [type-package-language-g.pkg] ";
if_debugging_show_package ("type_named_packages: result_package: [type-package-language-g.pkg] ", result_package, symbolmapstack');
# NOTE: bind_package modifies the varhome field of result_package;
# this may create packages with same ids but different dynamic
# accesses --- BUT, we assume that before or during the pickling,
# both the dynamic access and the inlining_data will be updated
# completely and replaced with proper persistent accesses (ZHONG)
#
my ( bound_package,
typechecked_package
)
=
case result_package
#
A_PACKAGE { typechecked_package, an_api, varhome, inlining_data }
=>
( A_PACKAGE { varhome => vh::named_varhome (name, make_var),
typechecked_package,
an_api,
inlining_data
},
mld::PACKAGE_ENTRY typechecked_package
);
_ => ( result_package,
mld::PACKAGE_ENTRY mld::bogus_typechecked_package
);
esac;
if_debugging_show_package("type_named_packages: bound_package: [type-package-language-g.pkg] ", bound_package, symbolmapstack');
declarations' = pkg_declaration ! declarations
where
pkg_declaration
=
ds::NAMED_PACKAGE
{
name_symbol => name,
a_package => bound_package,
definition => ds::PACKAGE_LET
{ declaration => result_declaration,
expression => ds::PACKAGE_BY_NAME result_package
}
};
end;
my ( typerstore',
module_declarations'
)
=
case syntactic_typechecking_context
#
trj::IN_GENERIC { flex, ... }
=>
{ typerstore1 = tro::atop_sp (typerstore_additions, typerstore);
typerstore2 = tro::set (typerstore1, rstamp, typechecked_package);
typerstore3 = tro::mark (make_fresh_stamp, typerstore2);
if_debugging_say "type_named_packages: about to map_paths bound_package [type-package-language-g.pkg] ";
# We are remapping macro_expansion_paths for elements of
# the new package unconditionally, even if
# there is no api constraint and the
# defining package_expression is PACKAGE_DEFINITION -- David MacQueen.
map_paths ( spc::enter_open (stamppath_context, THE rstamp),
bound_package,
flex
);
if_debugging_say "type_named_packages: map_paths bound_package done [type-package-language-g.pkg] ";
case bound_package
#
A_PACKAGE { an_api, typechecked_package, ... }
=>
spc::bind_stamppath (
stamppath_context,
mj::make_packagestamp (an_api, typechecked_package),
rstamp
);
_ => ();
esac;
( typerstore3,
mld::PACKAGE_DECLARATION (rstamp, result_package_expression, name) ! module_declarations
);
};
_ => ( typerstore,
module_declarations
);
esac;
if_debugging_show_package("type_named_packages: bound_package: [type-package-language-g.pkg] ", bound_package, symbolmapstack');
symbolmapstack'' = syx::bind (name, sxe::NAMED_PACKAGE bound_package, symbolmapstack');
loop (remaining_named_packages, declarations', symbolmapstack'', module_declarations', typerstore');
};
end; # fun loop
end; # where
} # function type_named_packages
# type_declaration'(): typecheck an arbitrary package-level declaration:
#
# Typechecking ultimately converts a raw syntax tree into
#
# o A deep syntax tree holding executable content and
# o Symbol table holding declarative content.
#
# Those account for our first two return values here.
#
# Our other two return values are internal typechecking
# information discarded at the completion of this
# typechecking call; they track information used during
# processing of generics.
#
also
fun type_declaration' (
#
raw_declaration: raw::Declaration, # Declaration being typechecked.
symbolmapstack: syx::Symbolmapstack, # Symbol table containing info from all .compiled files we depend on.
typerstore0: mld::Typerstore,
syntactic_typechecking_context: trj::Syntactic_Typechecking_Context,
top: Bool,
stamppath_context: spc::Context,
inverse_path: ip::Inverse_Path,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff as { make_fresh_stamp, issue_highcode_codetemp=>make_var, error_fn, deep_syntax_transform, ... }: trj::Per_Compile_Stuff
)
:
( ds::Declaration, # Typechecked version of raw_declaration.
syx::Symbolmapstack, # Contains (only) stuff from raw_declaration.
Module_Declaration,
Typerstore
)
=
{
if *debugging
#
unparse_raw_declaration
(
"type_declaration': unparsing declaration raw syntax: [type-package-language-g.pkg]\n",
raw_declaration,
symbolmapstack
);
prettyprint_raw_declaration
(
"type_declaration': prettyprinting declaration raw syntax: [type-package-language-g.pkg]\n",
raw_declaration,
symbolmapstack
);
fi;
case raw_declaration
#
raw::PACKAGE_DECLARATIONS named_packages
=>
type_named_packages
(
named_packages,
symbolmapstack,
typerstore0,
syntactic_typechecking_context,
stamppath_context,
inverse_path,
source_code_region,
per_compile_stuff
);
raw::INCLUDE_DECLARATIONS paths
=>
{ err = error_fn source_code_region;
#
packages = map path_to_package paths
where
fun path_to_package symbol_list
=
{ symbol_path = syp::SYMBOL_PATH symbol_list;
#
( symbol_path,
fst::find_package_via_symbol_path (symbolmapstack, symbol_path, err)
);
};
end;
loop (packages, syx::empty)
where
fun loop ([], symbolmapstack')
=>
( ds::INCLUDE_DECLARATIONS packages,
symbolmapstack',
mld::EMPTY_GENERIC_EVALUATION_DECLARATION,
tro::empty
);
loop ((_, s) ! r, symbolmapstack')
=>
loop (r, mj::include_package (symbolmapstack', s));
end;
end;
};
raw::GENERIC_DECLARATIONS named_generics
=>
{ if_debugging_say "type_declaration'/GENERIC_DECLARATIONS [type-package-language-g.pkg] ";
( loop (named_generics, NIL, syx::empty, NIL, tro::empty)
except
tro::UNBOUND
=
{ if_debugging_say ("@@type_declaration': GENERIC_DECLARATION [type-package-language-g.pkg] ");
raise exception tro::UNBOUND;
}
)
where
fun loop ([], declarations, symbolmapstack', module_declarations, typerstore')
=>
{ result_declaration = ds::GENERIC_DECLARATIONS (reverse declarations);
#
module_declaration
=
case module_declarations
#
[] => mld::EMPTY_GENERIC_EVALUATION_DECLARATION;
_ => module_declaration_sequence (reverse module_declarations);
esac;
if_debugging_say "type_declaration'/GENERIC_DECLARATIONS/ZZZ [type-package-language-g.pkg] ";
(result_declaration, symbolmapstack', module_declaration, typerstore');
};
loop (named_generic ! rest, declarations, symbolmapstack', module_declarations, typerstore')
=>
{ my ( name,
definition,
source_code_region'
)
=
case (strip_source_code_region_data_from_named_generics
(
named_generic,
source_code_region
))
#
(raw::NAMED_GENERIC { name_symbol, definition }, region)
=>
(name_symbol, definition, region);
_ => bug "non generic namings for GENERIC_DECLARATION named_generics";
esac;
if_debugging_say("type_declaration': GENERIC_DECLARATIONS/AAA [type-package-language-g.pkg] " + sy::name name);
# Dynamic varhome is assigned in type_generic:
#
my ( generic_abstract_declaration,
generic_expression,
a_generic,
typerstore_additions
)
=
type_generic
(
definition,
FALSE, # Not curried.
name,
symbolmapstack,
typerstore0,
syntactic_typechecking_context,
stamppath_context,
inverse_path,
source_code_region',
per_compile_stuff
);
# WARNING: bind_generic modifies the varhome field of a_generic;
# this may create generics with same ids but
# different dynamic accesses --- BUT, we assume that
# before or during the pickling, both the dynamic
# varhome and the inlining_data will be updated completely
# and replaced with proper persistent accesses (ZHONG)
#
my ( bind_generic,
typechecked_generic
)
=
case a_generic
#
GENERIC { typechecked_generic, a_generic_api, varhome, inlining_data }
=>
( GENERIC {
varhome => vh::named_varhome (name, make_var),
typechecked_generic,
a_generic_api,
inlining_data
},
GENERIC_ENTRY typechecked_generic
);
ERRONEOUS_GENERIC => (a_generic, ERRONEOUS_ENTRY);
esac;
fb = ds::NAMED_GENERIC { name_symbol => name,
a_generic => bind_generic,
definition => ds::GENERIC_LET (
generic_abstract_declaration,
ds::GENERIC_BY_NAME a_generic
)
};
declarations' = fb ! declarations;
my ( typerstore'',
module_declarations'
)
=
case syntactic_typechecking_context
#
trj::IN_GENERIC _
=>
{ module_stamp = make_fresh_stamp ();
#
case bind_generic
#
GENERIC _
=>
spc::bind_generic_path (
#
stamppath_context,
mj::genericstamp_of bind_generic,
module_stamp
);
ERRONEOUS_GENERIC => ();
esac;
typerstore1 = tro::atop_sp (
typerstore_additions,
typerstore'
);
typerstore2 = tro::set (
typerstore1,
module_stamp,
typechecked_generic
);
typerstore3 = tro::mark (
make_fresh_stamp,
typerstore2
);
( typerstore3,
#
mld::GENERIC_DECLARATION (
module_stamp,
generic_expression
)
!
module_declarations
);
};
_ => (typerstore', module_declarations);
esac;
symbolmapstack'' = syx::bind (
name,
sxe::NAMED_GENERIC bind_generic,
symbolmapstack'
);
loop (rest, declarations', symbolmapstack'', module_declarations', typerstore'');
};
end; # fun loop
end; # where
};
raw::API_DECLARATIONS named_apis
=>
{ if_debugging_say "type_api_bs [type-package-language-g.pkg] ";
( loop (named_apis, NIL, syx::empty)
except
tro::UNBOUND
=
{ if_debugging_say("@@type_declaration': API_DECLARATION [type-package-language-g.pkg] ");
raise exception tro::UNBOUND;
}
)
where
fun loop ([], apis, symbolmapstack')
=>
{
if_debugging_say "type_api_bs [type-package-language-g.pkg] ";
( ds::API_DECLARATIONS (reverse apis),
symbolmapstack',
mld::EMPTY_GENERIC_EVALUATION_DECLARATION,
tro::empty
);
};
loop (named_api ! rest, apis, symbolmapstack')
=>
{ my ( name,
definition,
source_code_region'
)
=
case (strip_source_code_region_data_from_named_api (named_api, source_code_region))
#
(raw::NAMED_API { name_symbol, definition }, region)
=>
(name_symbol, definition, region);
_ => bug "non api namings for API_DECLARATION named_apis";
esac;
if_debugging_say("type_declaration': [type-package-language-g.pkg] api " + sy::name name);
an_api = ta::type_api
{
api_expression => definition,
name_or_null => THE name,
symbolmapstack,
typerstore => typerstore0,
source_code_region => source_code_region',
stamppath_context,
per_compile_stuff
};
# Process to check well-formedness:
#
if (*typer_control::macro_expand_sigs)
#
ins::do_generic_parameter_api
{
an_api,
typerstore => tro::empty,
#
debruijn_depth => di::top,
inverse_path => ip::empty,
source_code_region => source_code_region',
per_compile_stuff
};
();
fi;
if_debugging_say ("type_declaration' [API_DECLARATIONS]: [type-package-language-g.pkg] binding NAMED_API " + (sy::name name));
loop ( rest,
an_api ! apis,
syx::bind (name, sxe::NAMED_API an_api, symbolmapstack')
);
};
end; # fun loop
end; # where
};
raw::GENERIC_API_DECLARATIONS named_generic_apis
=>
{ if_debugging_say "type_declaration'/GENERIC_API_DECLARATIONS [type-package-language-g.pkg] ";
( loop (named_generic_apis, NIL, syx::empty)
except
tro::UNBOUND
=
{ if_debugging_say ("@@type_declaration': GENERIC_API_DECLARATIONS [type-package-language-g.pkg] ");
raise exception tro::UNBOUND;
}
)
where
fun loop ([], generic_apis, symbolmapstack')
=>
{ if_debugging_say "type_declaration'/GENERIC_API_DECLARATIONS/ZZZ [type-package-language-g.pkg] ";
( ds::GENERIC_API_DECLARATIONS (reverse generic_apis),
symbolmapstack',
mld::EMPTY_GENERIC_EVALUATION_DECLARATION,
tro::empty
);
};
loop (named_generic_api ! rest, generic_apis, symbolmapstack')
=>
{ my (name,
definition,
source_code_region')
=
case (strip_source_code_region_data_from_named_generic_api
( named_generic_api,
source_code_region
))
(raw::NAMED_GENERIC_API { name_symbol=>n, definition=>d }, r)
=>
(n, d, r);
_
=>
bug "non Generic_Api namings for GENERIC_API_DECLARATIONS generic_named_apis";
esac;
if_debugging_say("type_declaration'/GENERIC_API_DECLARATIONS/LLL: [type-package-language-g.pkg} generic_api " + sy::name name);
s = ta::type_generic_api
{
generic_api_expression => definition,
name_or_null => THE name,
symbolmapstack,
typerstore => typerstore0,
stamppath_context,
source_code_region => source_code_region',
per_compile_stuff
};
loop (
rest,
s ! generic_apis,
syx::bind (name, sxe::NAMED_GENERIC_API s, symbolmapstack')
);
};
end; # fun loop
end; # where
};
raw::LOCAL_DECLARATIONS (declaration_in, declaration_out)
=>
{ top_in = trj::contains_package_declaration declaration_in or
trj::contains_package_declaration declaration_out;
# If declaration_in contains a generic declaration (at
# any nesting depth) we must suppress ungeneralized
# type variables to avoid bug 905/952.
#
# Using TRJ::contains_package_declaration is a cheap conservative approximation
# to checking for the presence of generic declarations,
# although it excludes some legal SML 96 programs where
# packages but not generics are present.
my ( deep_syntax_tree_in,
env_in,
entdeclaration_in,
input_typerstore
)
=
type_declaration' (
declaration_in,
symbolmapstack,
typerstore0,
syntactic_typechecking_context,
top_in,
stamppath_context,
inverse_path,
source_code_region,
per_compile_stuff
);
# ** DAVE? what is the right stamppath_context to pass here? XXX BUGGO FIXME **
symbolmapstack' = syx::atop (env_in, symbolmapstack);
typerstore' = tro::mark (
make_fresh_stamp,
tro::atop (input_typerstore, typerstore0)
);
my ( deep_syntax_tree_out,
env_out,
entdeclaration_out,
output_typerstore
)
=
type_declaration' (
declaration_out,
symbolmapstack',
typerstore',
syntactic_typechecking_context,
top,
stamppath_context,
inverse_path,
source_code_region,
per_compile_stuff
);
result_deep_syntax_tree
=
ds::LOCAL_DECLARATIONS (deep_syntax_tree_in, deep_syntax_tree_out);
my ( module_declaration,
result_typerstore
)
=
case syntactic_typechecking_context
#
trj::IN_GENERIC _
=>
( local_module_declaration (entdeclaration_in, entdeclaration_out),
tro::mark (
make_fresh_stamp,
tro::atop (output_typerstore, input_typerstore)
)
);
_ => (mld::EMPTY_GENERIC_EVALUATION_DECLARATION, tro::empty);
esac;
( result_deep_syntax_tree,
env_out,
module_declaration,
result_typerstore
);
};
raw::SEQUENTIAL_DECLARATIONS declarations
=>
{ if_debugging_say "type_declaration'/SEQUENTIAL_DECLARATIONS [type-package-language-g.pkg] ";
( loop (declarations, NIL, syx::empty, NIL, tro::empty)
except
tro::UNBOUND
=
{ if_debugging_say("@@type_declaration': SEQUENTIAL_DECLARATIONS [type-package-language-g.pkg] ");
raise exception tro::UNBOUND;
}
)
where
fun loop ([], asdeclarations, symbolmapstack', module_declarations, typerstore')
=>
{ result_deep_syntax_tree
=
ds::SEQUENTIAL_DECLARATIONS (reverse asdeclarations);
my ( module_declaration',
typerstore''
)
=
case syntactic_typechecking_context
#
trj::IN_GENERIC _
=>
( module_declaration_sequence (reverse module_declarations),
typerstore'
);
_ => (mld::EMPTY_GENERIC_EVALUATION_DECLARATION, tro::empty);
esac;
debug_print ("type_declaration'/SEQUENTIAL_DECLARATIONS/ZZZ - symbols: ", bug::prettyprint_symbol_list, bug::symbolmapstack_symbols symbolmapstack');
if_debugging_say "type_declaration'/SEQUENTIAL_DECLARATIONS/ZZZZ [type-package-language-g.pkg] ";
(result_deep_syntax_tree, symbolmapstack', module_declaration', typerstore'');
};
loop (declaration ! rest, asdeclarations, symbolmapstack', module_declarations, typerstore')
=>
{ symbolmapstack1 = syx::atop (symbolmapstack', symbolmapstack);
#
typerstore1 = tro::mark ( make_fresh_stamp,
tro::atop (typerstore', typerstore0)
);
my ( deep_syntax_declaration,
symbolmapstack'',
module_declaration,
typerstore''
)
=
type_declaration' (
declaration,
symbolmapstack1,
typerstore1,
syntactic_typechecking_context,
top,
stamppath_context,
inverse_path,
source_code_region,
per_compile_stuff
);
loop (
rest,
deep_syntax_declaration ! asdeclarations,
syx::atop (symbolmapstack'', symbolmapstack'),
module_declaration ! module_declarations,
tro::mark (
make_fresh_stamp,
tro::atop (typerstore'', typerstore')
)
);
};
end; # fun loop
end; # where
};
raw::TYPE_DECLARATIONS named_types # ** ASSERT: the types declared are all DEFtypes **
=>
( { my ( declaration,
symbolmapstack'
)
=
tt::type_type_declaration (
named_types,
symbolmapstack,
inverse_path,
source_code_region,
per_compile_stuff
);
types = case declaration
ds::TYPE_DECLARATIONS z
=>
z;
_ => bug "type_declaration' for TYPE_DECLARATIONS";
esac;
my ( typerstore',
module_declaration
)
=
bind_new_types (
syntactic_typechecking_context,
stamppath_context,
make_fresh_stamp,
[],
types,
inverse_path,
error_fn source_code_region
);
( declaration,
symbolmapstack',
module_declaration,
typerstore'
);
}
except
tro::UNBOUND
=
{ if_debugging_say("@@type_declaration': TYPE_DECLARATIONS [type-package-language-g.pkg] ");
raise exception tro::UNBOUND;
}
);
raw::SUMTYPE_DECLARATIONS (x as { sumtypes, with_types } )
=>
case sumtypes
#
(raw::SUM_TYPE { right_hand_side => (raw::VALCONS _), ... } ) ! _
=>
{ is_free = case syntactic_typechecking_context
#
trj::IN_GENERIC _
=>
(\\ type
=
case (spc::find_stamppath_for_type (
stamppath_context,
mj::typestamp_of type
))
#
THE _ => TRUE;
_ => FALSE;
esac
);
_ => (\\ _ = FALSE);
esac;
my ( sumtypes,
with_types,
_,
symbolmapstack'
)
=
tt::type_sumtype_declaration (
x,
symbolmapstack,
[],
tro::empty,
is_free,
inverse_path,
source_code_region,
per_compile_stuff
);
my ( typerstore',
module_declaration
)
=
bind_new_types (
syntactic_typechecking_context,
stamppath_context,
make_fresh_stamp,
sumtypes,
with_types,
inverse_path,
error_fn source_code_region
);
result_declaration
=
ds::SUMTYPE_DECLARATIONS { sumtypes, with_types };
( result_declaration,
symbolmapstack',
module_declaration,
typerstore'
);
};
(raw::SUM_TYPE { name_symbol,
right_hand_side => raw::REPLICAS symbols,
typevars => NIL,
is_lazy => FALSE
}
!
NIL
)
=>
{ fun no_sumtype ()
=
{ error_fn
source_code_region
err::ERROR
"rhs of sumtype replication not a sumtype"
err::null_error_body;
( ds::SEQUENTIAL_DECLARATIONS [],
syx::empty,
mld::ERRONEOUS_ENTRY_DECLARATION,
tro::empty
);
};
case with_types
#
_ ! _
=>
{ error_fn
source_code_region
err::ERROR
"withtype not allowed in sumtype replication"
err::null_error_body;
( ds::SEQUENTIAL_DECLARATIONS [],
syx::empty,
mld::ERRONEOUS_ENTRY_DECLARATION,
tro::empty
);
};
[] =>
{ type = fst::find_type_via_symbol_path (
symbolmapstack,
syp::SYMBOL_PATH symbols,
error_fn source_code_region
);
case type
#
tdt::SUM_TYPE { kind => tdt::SUMTYPE _, ... }
=>
{ dcons = tu::extract_sumtype type;
#
env_dcons
=
fold_forward (\\ (d as tdt::VALCON { name, ... }, e)
=
syx::bind (
name,
sxe::NAMED_CONSTRUCTOR d,
e
)
)
syx::empty dcons;
symbolmapstack'
=
syx::bind (
name_symbol,
sxe::NAMED_TYPE type,
env_dcons
);
module_stamp = make_fresh_stamp ();
stamp_of_type = mj::typestamp_of type;
my ( ee_dec,
ee_env
)
=
case syntactic_typechecking_context
#
trj::IN_GENERIC _
=>
{ texp = case (spc::find_stamppath_for_type (stamppath_context, stamp_of_type))
#
NULL => mld::CONSTANT_TYPE type;
THE stamppath => mld::TYPEVAR_TYPE stamppath;
esac;
( mld::TYPE_DECLARATION (module_stamp, texp),
tro::set (
tro::empty,
module_stamp,
mld::TYPE_ENTRY type
)
);
};
_ => (mld::EMPTY_GENERIC_EVALUATION_DECLARATION, tro::empty);
esac;
result_declaration
=
ds::SUMTYPE_DECLARATIONS {
sumtypes => [ type ],
with_types => [ ]
};
spc::bind_typepath (stamppath_context, stamp_of_type, module_stamp);
(result_declaration, symbolmapstack', ee_dec, ee_env);
};
_ => no_sumtype ();
esac;
};
esac;
};
_ => { error_fn
source_code_region
err::ERROR
"argument type variables in sumtype replication"
err::null_error_body;
( ds::SEQUENTIAL_DECLARATIONS [],
syx::empty,
mld::ERRONEOUS_ENTRY_DECLARATION,
tro::empty
);
};
esac;
raw::SOURCE_CODE_REGION_FOR_DECLARATION (declaration', source_code_region')
=>
type_declaration' (
declaration',
symbolmapstack,
typerstore0,
syntactic_typechecking_context,
top,
stamppath_context,
inverse_path,
source_code_region',
per_compile_stuff
);
declaration
=>
( { is_free = case syntactic_typechecking_context
#
trj::IN_GENERIC _
=>
( \\ type
=
case (spc::find_stamppath_for_type (
stamppath_context,
mj::typestamp_of type
))
THE _ => TRUE;
_ => FALSE;
esac
);
_ => (\\ _ = FALSE);
esac;
my ( declaration,
symbolmapstack''
)
=
tcl::type_declaration
(
declaration,
symbolmapstack,
is_free,
inverse_path,
source_code_region,
per_compile_stuff
)
except
tro::UNBOUND = { if_debugging_say ("@@tcl::type_declaration [type-package-language-g.pkg] ");
raise exception tro::UNBOUND;
};
if_debugging_say
( "type_declaration'/declaration [type-package-language-g.pkg] [after tcl::type_declaration: top="
+ (bool::to_string top)
+ "]"
);
declaration' = deep_syntax_transform declaration;
if_debugging_say "type_declaration'/declaration [type-package-language-g.pkg] [after deep_syntax_transform]";
declaration''
=
tcd::type_core_language_declaration # SIDE-EFFECTS: Sets tdt::TYPEVAR_REF.ref_typevar (in unify_typoids) and vac::PLAIN_VARIABLE.vartypoid_ref (in generalize_*).
{
symbolmapstack => syx::atop (symbolmapstack'', symbolmapstack),
declaration => declaration',
outside_all_lets => top,
error_function => error_fn,
source_code_region
}
except
tro::UNBOUND
=
{ if_debugging_say("@@type_core_language_declaration [type-package-language-g.pkg] ");
raise exception tro::UNBOUND;
};
if_debugging_say "type_declaration'/declaration [after type_core_language_declaration] [type-package-language-g.pkg] ";
( declaration'', # Typechecked version of raw_declaration.
symbolmapstack'', # Contains (only) stuff from raw_declaration.
mld::EMPTY_GENERIC_EVALUATION_DECLARATION,
tro::empty
);
}
except
tro::UNBOUND
=
{ if_debugging_say("@@type_declaration': Core_Declaration [type-package-language-g.pkg] ");
raise exception tro::UNBOUND;
}
);
esac;
}; # fun type_declaration'
# The top-level wrapper of the type_declaration' function:
#
fun type_declaration # Called (only) from type_declaration in src/lib/compiler/front/typer/main/translate-raw-syntax-to-deep-syntax-g.pkg {
raw_declaration, # Declaration being typechecked.
symbolmapstack,
typerstore,
syntactic_typechecking_context,
level,
stamppath_context,
path,
source_code_region,
per_compile_stuff
}
=
{
if *debugging
#
unparse_raw_declaration
(
"type_declaration/AAA: unparsing declaration raw syntax: [type-package-language-g.pkg]\n",
raw_declaration,
symbolmapstack
);
prettyprint_raw_declaration
(
"type_declaration/AAA: prettyprinting declaration raw syntax: [type-package-language-g.pkg] \n",
raw_declaration,
symbolmapstack
);
fi;
my ( deep_syntax_declaration, # Typechecked version of raw_declaration.
symbolmapstack, # Contains (only) stuff from raw_declaration.
_,
_
)
=
type_declaration'
(
raw_declaration, # Declaration being typechecked.
symbolmapstack, # Symbol table containing info from all .compiled files we depend on.
typerstore,
syntactic_typechecking_context,
level,
stamppath_context,
path,
source_code_region,
per_compile_stuff
);
{ deep_syntax_declaration, # Typechecked version of raw_declaration.
symbolmapstack # Contains (only) stuff from raw_declaration.
};
};
}; # generic package type_package_language_g
end; # stipulate