## include.pkg
# Compiled by:
# src/lib/compiler/front/typer/typer.sublibstipulate
package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package mp = stamppath; # stamppath is from src/lib/compiler/front/typer-stuff/modules/stamppath.pkg package mj = module_junk; # module_junk is from src/lib/compiler/front/typer-stuff/modules/module-junk.pkg package sta = stamp; # stamp is from src/lib/compiler/front/typer-stuff/basics/stamp.pkg package sxe = symbolmapstack_entry; # symbolmapstack_entry is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack-entry.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package ts = typer_junk; # typer_junk is from src/lib/compiler/front/typer/main/typer-junk.pkg package tu = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.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 #
# include package module_level_declarations;
herein
package include_mumble: (weak) Include { # Include is from src/lib/compiler/front/typer/main/include.api fun bug msg
=
err::impossible ("Include: " + msg);
debugging = REF FALSE;
say = control_print::say;
fun if_debugging_say (msg: String)
=
if *debugging
say msg;
say "\n";
fi;
fun add_element (element, elements)
=
element ! elements;
fun subst_elem ( new as (name, spec),
(old as (name', _)) ! rest
)
=>
if (sy::eq (name, name')) new ! rest;
else old ! subst_elem (new, rest);
fi;
subst_elem (_, NIL)
=>
bug "substElem";
end;
Tyc_Compat = KEEP_OLD
| REPLACE
| INCOMPATIBLE;
fun compatible (newtyc, oldtyc)
=
if ( tu::arity_of_type newtyc
!= tu::arity_of_type oldtyc
)
#
INCOMPATIBLE;
else
case (newtyc, oldtyc)
#
( tdt::SUM_TYPE { kind, ... },
tdt::SUM_TYPE { kind => kind', ... }
)
=>
case (kind, kind')
#
(tdt::FORMAL, tdt::FORMAL) => KEEP_OLD;
( _, tdt::FORMAL) => REPLACE;
_ => INCOMPATIBLE;
esac;
_ => INCOMPATIBLE;
esac;
fi;
fun specified (symbol, elements)
=
list::exists
(\\ (n, _) = sy::eq (symbol, n))
elements;
# Typechecking IMPORT_IN_API in apis:
# XXX BUGGO FIXME Currently doesn't deal with general api_expression case (e.g. sigid where ...)
fun typecheck_include (
mld::API
{
stamp,
api_elements => new_elements,
symbols => new_symbols,
property_list,
type_sharing,
package_sharing,
name,
closed,
contains_generic,
stub
},
old_dictionary,
old_elements,
old_symbols,
old_slots,
source_code_region,
per_compile_stuff as { make_fresh_stamp, error_fn, ... } : ts::Per_Compile_Stuff
)
=>
{ err = error_fn source_code_region;
# When including a list of specs into the current api;
# some type's macroExpansionVars might be adjusted,
# this would force all the types in the specs to be adjusted also.
# This adjustment is implemented using this tycmap table.
#
exception TYPE_MAP;
tyc_map = REF ([]: List( (sta::Stamp, tdt::Type) ));
fun add_map z = tyc_map := (z ! *tyc_map);
fun get_map z = *tyc_map;
fun get_type_map (ev, [])
=>
raise exception TYPE_MAP;
get_type_map
(
ev,
(ev', type) ! rest
)
=>
if (mp::same_module_stamp (ev, ev')) type;
else get_type_map (ev, rest);
fi;
end;
# adjust_typoid does not get inside each
# NAMED_TYPE's body
# because we assume that the body
# has been adjusted already:
#
fun adjust_typoid (typoid, [] )
=>
typoid;
adjust_typoid (typoid, tycmap)
=>
tu::map_constructor_typoid_dot_type newtyc typoid
where
fun newtyc (type as tdt::TYPE_BY_STAMPPATH { stamppath => [ev], ... } )
=>
get_type_map (ev, tycmap)
except
TYPE_MAP = type;
newtyc type
=>
type;
end;
end;
end;
# adjust_type() is only
# called at each type specification site.
#
# The stamp for NAMED_TYPE
# is changed; fortunately, this is OK
# because all other references to this
# NAMED_TYPE are via
# tdt::TYPE_BY_STAMPPATH.
#
fun adjust_type (type, [] )
=>
type;
adjust_type (type, tycmap)
=>
case type
#
tdt::NAMED_TYPE
{
strict,
namepath,
stamp => s,
typescheme => tdt::TYPESCHEME { arity, body }
}
=>
tdt::NAMED_TYPE
{
strict,
namepath,
stamp => make_fresh_stamp(),
#
typescheme => tdt::TYPESCHEME { arity,
body => adjust_typoid (body, tycmap)
}
};
tdt::SUM_TYPE _
=>
type;
tdt::TYPE_BY_STAMPPATH { stamppath => [ev], ... }
=>
( get_type_map (ev, tycmap)
except
TYPE_MAP = type
);
_ => bug "adjust_type";
esac;
end
# Changing the stamp of an ANONYMOUS
# api may cause unnecessary
# api matching operations:
#
also
fun adjust_sig (an_api, [])
=>
an_api;
adjust_sig
(
an_api as
mld::API {
stamp,
name,
closed,
contains_generic,
api_elements,
symbols,
property_list,
type_sharing,
package_sharing,
stub
},
tycmap
)
=>
if closed
an_api;
else
mld::API {
stamp => make_fresh_stamp(),
name,
closed => FALSE,
stub => NULL,
property_list => property_list::make_property_list (),
api_elements => adjust_elems (api_elements, tycmap),
symbols,
type_sharing,
contains_generic,
package_sharing
};
fi;
adjust_sig _
=>
bug "adjust_sig";
end
also
fun adjust_generic_api (
an_api as
mld::GENERIC_API {
kind,
parameter_api,
body_api,
parameter_variable,
parameter_symbol
},
tycmap
)
=>
{ parameter_api' = adjust_sig (parameter_api, tycmap);
body_api' = adjust_sig (body_api, tycmap);
mld::GENERIC_API {
kind,
parameter_api => parameter_api',
body_api => body_api',
parameter_variable,
parameter_symbol
};
};
adjust_generic_api _
=>
bug "adjust_generic_api";
end
also
fun adjust_elems (api_elements, tycmap)
=
map (adjust_elem tycmap) api_elements
also
fun adjust_elem tycmap (symbol, spec)
=
{ nspec = case spec
#
mld::TYPE_IN_API
{
type,
module_stamp => ev,
is_a_replica => r,
scope => s
}
=>
mld::TYPE_IN_API
{
type => adjust_type (type, tycmap),
module_stamp => ev,
is_a_replica => r,
scope => s
};
mld::PACKAGE_IN_API
{
an_api,
module_stamp => ev,
definition => d,
slot => s
}
=>
mld::PACKAGE_IN_API
{
an_api => adjust_sig (an_api, tycmap),
module_stamp => ev,
definition => d,
slot => s
};
# BUG: def component may need adjustment? XXX FIXME BUGGO
mld::GENERIC_IN_API { a_generic_api, module_stamp=>ev, slot=>s }
=>
mld::GENERIC_IN_API { a_generic_api => adjust_generic_api (a_generic_api, tycmap), module_stamp=>ev, slot=>s };
mld::VALUE_IN_API { typoid, slot }
=>
mld::VALUE_IN_API { typoid => adjust_typoid (typoid, tycmap), slot };
mld::VALCON_IN_API
{
slot => s,
#
sumtype => tdt::VALCON
{
form,
name,
typoid,
is_constant,
signature,
is_lazy
}
}
=>
mld::VALCON_IN_API
{
slot => s,
#
sumtype => tdt::VALCON
{
name,
is_constant,
is_lazy,
#
form,
signature,
#
typoid => adjust_typoid (typoid, tycmap)
}
};
esac;
(symbol, nspec);
};
fun add_elem ((name, nspec: mld::Api_Element), dictionary, elems, syms, slot)
=
case nspec
#
mld::TYPE_IN_API
{
type => tc,
module_stamp => ev,
is_a_replica => r,
scope => s
}
=>
{ my { type => otc, module_stamp => oev, is_a_replica => or_op, scope => os } # 'o' for 'old'?
=
case (mj::get_api_element (elems, name))
#
mld::TYPE_IN_API x => x;
_ => bug "addElem: TYPE_IN_API";
esac;
case (compatible (tc, otc))
#
KEEP_OLD
=>
{ ntc = tdt::TYPE_BY_STAMPPATH
{
arity => tu::arity_of_type otc,
stamppath => [oev],
namepath => ip::INVERSE_PATH [name]
};
add_map (ev, ntc);
(dictionary, elems, syms, slot);
};
REPLACE
=>
{ ntc = adjust_type (tc, get_map());
nspec' =
mld::TYPE_IN_API
{
type => ntc,
module_stamp => oev,
is_a_replica => or_op,
scope => s
}; # ? XXX BUGGO FIXME
elems' = subst_elem ( (name, nspec'), elems);
ntc = tdt::TYPE_BY_STAMPPATH
{
arity => tu::arity_of_type ntc,
stamppath => [oev],
namepath => ip::INVERSE_PATH [ name ]
};
add_map (ev, ntc);
(dictionary, elems', syms, slot);
};
INCOMPATIBLE
=>
{ err
err::ERROR
( "duplicate specifications for type "
+ sy::name name
+ " caused by include"
)
err::null_error_body;
(dictionary, elems, syms, slot);
};
esac;
} except
mj::UNBOUND _
=
# New type
{ ntyc
=
tdt::TYPE_BY_STAMPPATH
{
arity => tu::arity_of_type tc,
stamppath => [ev],
namepath => ip::INVERSE_PATH [ name ]
};
dictionary'
=
syx::bind (
name,
sxe::NAMED_TYPE ntyc,
dictionary
);
spec' = mld::TYPE_IN_API { type => adjust_type (tc, get_map()),
module_stamp => ev,
is_a_replica => r,
scope => s
};
elems' = add_element( (name, spec'), elems);
syms' = name ! syms;
(dictionary', elems', syms', slot);
};
mld::PACKAGE_IN_API { an_api, module_stamp, definition, ... }
=>
if (specified (name, elems))
#
err
err::ERROR
( "duplicate specifications for package "
+ sy::name name
+ " caused by include"
)
err::null_error_body;
(dictionary, elems, syms, slot);
else
# New specification is ok:
newsign = adjust_sig (an_api, get_map());
newspec = mld::PACKAGE_IN_API
{
an_api => newsign,
slot,
module_stamp,
definition
};
nstr = mld::PACKAGE_API { an_api => newsign,
stamppath => [ module_stamp ]
};
dictionary' = syx::bind (
name,
sxe::NAMED_PACKAGE nstr,
dictionary
);
elems' = add_element ((name, newspec), elems);
syms' = name ! syms;
(dictionary', elems', syms', slot+1);
fi;
mld::GENERIC_IN_API { a_generic_api, module_stamp, ... }
=>
if (specified (name, elems))
#
err
err::ERROR
( "duplicate specifications for generic package "
+ sy::name name
+ " caused by include"
)
err::null_error_body;
(dictionary, elems, syms, slot);
else
# New specification is ok:
newsign
=
adjust_generic_api (a_generic_api, get_map());
newspec
=
mld::GENERIC_IN_API
{
a_generic_api => newsign,
slot,
module_stamp
};
elems'
=
add_element ((name, newspec), elems);
syms'
=
name ! syms;
(dictionary, elems', syms', slot+1);
fi;
mld::VALUE_IN_API { typoid, ... }
=>
if (specified (name, elems))
#
err
err::ERROR
( "duplicate value specifications for "
+ sy::name name
+ " caused by include"
)
err::null_error_body;
(dictionary, elems, syms, slot);
else # New specification is ok:
newtypoid = adjust_typoid (typoid, get_map());
newspec = mld::VALUE_IN_API { typoid => newtypoid, slot };
elems' = add_element ((name, newspec), elems);
syms' = name ! syms;
(dictionary, elems', syms', slot+1);
fi;
mld::VALCON_IN_API
{
sumtype => tdt::VALCON
{
form,
name,
typoid,
is_constant,
signature,
is_lazy
},
...
}
=>
if (specified (name, elems))
#
err
err::ERROR
( "duplicate constructor specifications for "
+ sy::name name
+ " caused by include"
)
err::null_error_body;
(dictionary, elems, syms, slot);
else # New specification is ok:
typoid = adjust_typoid (typoid, get_map());
ndcon =
tdt::VALCON
{
typoid,
signature,
form,
name,
is_constant,
is_lazy
};
my (slot_op, slot')
=
case form
#
vh::EXCEPTION _ => (THE slot, slot+1);
_ => (NULL, slot );
esac;
newspec
=
mld::VALCON_IN_API {
#
sumtype => ndcon,
slot => slot_op
};
elems' = add_element( (name, newspec), elems);
syms' = name ! syms;
(dictionary, elems', syms', slot');
fi;
esac; # fun add_elem
fun add_elems (nelems, [], dictionary, elems, syms, slot)
=>
(dictionary, elems, syms, slot);
add_elems (e ! nelems, s ! rest, dictionary, elems, syms, slot)
=>
{ # Should use s to search for e in nelems if
# elements is represented as a real dictionary. XXX BUGGO FIXME
my (dictionary', elems', syms', slot')
=
add_elem (e, dictionary, elems, syms, slot);
add_elems (nelems, rest, dictionary', elems', syms', slot');
};
add_elems _
=>
bug "add_elems";
end;
my (dictionary', elems', syms', slots')
=
add_elems (
new_elements,
new_symbols,
old_dictionary,
old_elements,
old_symbols,
old_slots
);
(dictionary', elems', syms', type_sharing, package_sharing, slots', contains_generic);
}; # end of case #1 for function typecheck_include
typecheck_include (mld::ERRONEOUS_API, dictionary, elems, syms, slots, source_code_region, comp_info)
=>
(dictionary, elems, syms, [], [], slots, FALSE);
end; # fun typecheck_include
}; # package include
end; # stipulate