## 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 ty = types; # types is from src/lib/compiler/front/typer-stuff/types/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 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::typ_arity newtyc
!= tu::typ_arity oldtyc
)
#
INCOMPATIBLE;
else
case (newtyc, oldtyc)
#
( ty::PLAIN_TYP { kind, ... },
ty::PLAIN_TYP { kind => kind', ... }
)
=>
case (kind, kind')
#
(ty::FORMAL, ty::FORMAL) => KEEP_OLD;
( _, ty::FORMAL) => REPLACE;
_ => INCOMPATIBLE;
esac;
_ => INCOMPATIBLE;
esac;
fi;
fun specified (symbol, elements)
=
list::exists
(fn (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_info as { make_fresh_stamp, error_fn, ... } : ts::Per_Compile_Info
)
=>
{ err = error_fn source_code_region;
# When including a list of specs into the current api;
# some typ'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 TYP_MAP;
tyc_map = REF ([]: List( (sta::Stamp, ty::Typ) ));
fun add_map z = tyc_map := (z ! *tyc_map);
fun get_map z = *tyc_map;
fun get_typ_map (ev, [])
=>
raise exception TYP_MAP;
get_typ_map
(
ev,
(ev', typ) ! rest
)
=>
if (mp::same_module_stamp (ev, ev')) typ;
else get_typ_map (ev, rest);
fi;
end;
# adjust_type does not get inside each
# DEFINED_TYP's body
# because we assume that the body
# has been adjusted already:
#
fun adjust_type (type, [] )
=>
type;
adjust_type (type, tycmap)
=>
tu::map_constructor_type_dot_typ
newtyc
type
where
fun newtyc (typ as ty::TYP_BY_STAMPPATH { stamppath => [ev], ... } )
=>
get_typ_map (ev, tycmap)
except
TYP_MAP
=
typ;
newtyc typ
=>
typ;
end;
end;
end;
# adjust_typ() is only
# called at each type specification site.
#
# The stamp for DEFINED_TYP
# is changed; fortunately, this is OK
# because all other references to this
# DEFINED_TYP are via
# ty::TYP_BY_STAMPPATH.
#
fun adjust_typ (typ, [] )
=>
typ;
adjust_typ (typ, tycmap)
=>
case typ
#
ty::DEFINED_TYP
{
strict,
path,
stamp => s,
type_scheme => ty::TYPE_SCHEME { arity, body }
}
=>
ty::DEFINED_TYP
{
strict,
path,
stamp => make_fresh_stamp(),
#
type_scheme => ty::TYPE_SCHEME { arity,
body => adjust_type (body, tycmap)
}
};
ty::PLAIN_TYP _
=>
typ;
ty::TYP_BY_STAMPPATH { stamppath => [ev], ... }
=>
( get_typ_map (ev, tycmap)
except
TYP_MAP
=
typ
);
_ => bug "adjust_typ";
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::TYP_IN_API
{
typ,
module_stamp => ev,
is_a_replica => r,
scope => s
}
=>
mld::TYP_IN_API
{
typ => adjust_typ (typ, 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 { type, slot }
=>
mld::VALUE_IN_API { type=>adjust_type (type, tycmap), slot };
mld::VALCON_IN_API
{
slot => s,
#
datatype => ty::VALCON
{
form,
name,
type,
is_constant,
signature,
is_lazy
}
}
=>
mld::VALCON_IN_API
{
slot => s,
#
datatype => ty::VALCON
{
name,
is_constant,
is_lazy,
#
form,
signature,
#
type => adjust_type (type, tycmap)
}
};
esac;
(symbol, nspec);
};
fun add_elem ((name, nspec: mld::Api_Element), dictionary, elems, syms, slot)
=
case nspec
#
mld::TYP_IN_API
{
typ => tc,
module_stamp => ev,
is_a_replica => r,
scope => s
}
=>
{ my { typ => otc, module_stamp => oev, is_a_replica => or_op, scope => os } # 'o' for 'old'?
=
case (mj::get_api_element (elems, name))
#
mld::TYP_IN_API x => x;
_ => bug "addElem: TYP_IN_API";
esac;
case (compatible (tc, otc))
KEEP_OLD
=>
{ ntc =
ty::TYP_BY_STAMPPATH
{
arity => tu::typ_arity otc,
stamppath => [oev],
path => ip::INVERSE_PATH [name]
};
add_map (ev, ntc);
(dictionary, elems, syms, slot);
};
REPLACE
=>
{ ntc = adjust_typ (tc, get_map());
nspec' =
mld::TYP_IN_API
{
typ => ntc,
module_stamp => oev,
is_a_replica => or_op,
scope => s
}; # ? XXX BUGGO FIXME
elems' = subst_elem ( (name, nspec'), elems);
ntc = ty::TYP_BY_STAMPPATH
{
arity => tu::typ_arity ntc,
stamppath => [oev],
path => 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 typ
{ ntyc
=
ty::TYP_BY_STAMPPATH
{
arity => tu::typ_arity tc,
stamppath => [ev],
path => ip::INVERSE_PATH [name]
};
dictionary'
=
syx::bind (
name,
sxe::NAMED_TYPE ntyc,
dictionary
);
spec' =
mld::TYP_IN_API
{
typ => adjust_typ (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 { type, ... }
=>
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:
newtyp = adjust_type (type, get_map());
newspec = mld::VALUE_IN_API { type => newtyp, slot };
elems' = add_element ((name, newspec), elems);
syms' = name ! syms;
(dictionary, elems', syms', slot+1);
fi;
mld::VALCON_IN_API
{
datatype => ty::VALCON
{
form,
name,
type,
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:
type
=
adjust_type (type, get_map());
ndcon =
ty::VALCON
{
type,
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 {
#
datatype => 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