## find-in-symbolmapstack.pkg
# Compiled by:
# src/lib/compiler/front/typer-stuff/typecheckdata.sublibstipulate
package cvp = invert_path; # invert_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package mj = module_junk; # module_junk is from src/lib/compiler/front/typer-stuff/modules/module-junk.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 sxe = symbolmapstack_entry; # symbolmapstack_entry is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack-entry.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package tj = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package 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.pkgherein
package find_in_symbolmapstack
: (weak) Find_In_Symbolmapstack # Find_In_Symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/find-in-symbolmapstack.api {
#
fun bug s
=
err::impossible ("find-in-symbolmapstack.pkg: " + s);
#
fun spmsg spath
=
if (syp::length spath > 1 ) " in path " + (syp::to_string spath);
else "";
fi;
#
fun unbound_error (badsym, sp, err)
=
err err::ERROR ( "unbound "
+ sy::name_space_to_string (sy::name_space badsym)
+ ": "
+ sy::name badsym
+ sp
)
err::null_error_body;
#
fun other_error (s, err)
=
err err::ERROR s err::null_error_body;
# Error values for undefined package and generic package variables
bogus_package = mld::ERRONEOUS_PACKAGE;
bogus_g = mld::ERRONEOUS_GENERIC;
bogus_value = vac::VARIABLE vac::ERROR_VARIABLE;
# Look up a fixity naming:
#
fun find_fixity_by_symbol (symbolmapstack, id) : fixity::Fixity
=
case (syx::get (symbolmapstack, id))
#
sxe::NAMED_FIXITY fixity => fixity;
_ => bug "lookUpFIX";
esac
except syx::UNBOUND
=
fixity::NONFIX;
# Look up a api:
#
fun find_api_by_symbol (symbolmapstack, id, err) : mld::Api
=
case (syx::get (symbolmapstack, id) )
#
sxe::NAMED_API an_api => an_api;
_ => bug "lookUpSIG";
esac
except syx::UNBOUND = { unbound_error (id, "", err);
mld::ERRONEOUS_API;
};
# Look up a generic api:
#
fun find_generic_api_by_symbol (symbolmapstack, id, err) : mld::Generic_Api
=
case (syx::get (symbolmapstack, id) )
#
sxe::NAMED_GENERIC_API fs => fs;
_ => bug "lookUpFSIG";
esac
except syx::UNBOUND = { unbound_error (id, "", err); mld::ERRONEOUS_GENERIC_API; };
# Look up a variable or a constructor bound to a symbol:
#
fun find_value_by_symbol (symbolmapstack, symbol, err) : vac::Variable_Or_Constructor
=
case (syx::get (symbolmapstack, symbol))
#
sxe::NAMED_VARIABLE v => vac::VARIABLE v;
sxe::NAMED_CONSTRUCTOR c => vac::CONSTRUCTOR c;
_ => bug "find_value_by_symbol";
esac
except
syx::UNBOUND
=
{ unbound_error (symbol, "", err);
bogus_value;
};
# Look up path
# generic_lookup: generic lookup function for identifiers which may occur in:
# 1. symbol tables
# 2. actual package dictionaries
# 3. api parsing dictionaries
#
fun generic_lookup (symbolmapstack, spath, out_bind, get_path, error_val, err)
=
case spath
#
syp::SYMBOL_PATH [id]
=>
out_bind (syx::get (symbolmapstack, id))
except
syx::UNBOUND
=
{ unbound_error (id, spmsg spath, err);
error_val;
};
syp::SYMBOL_PATH (first ! rest)
=>
case (syx::get (symbolmapstack, first))
#
sxe::NAMED_PACKAGE a_package
=>
get_path (a_package, syp::SYMBOL_PATH rest, spath)
except
mj::UNBOUND symbol
=
{ unbound_error (symbol, spmsg spath, err);
error_val;
};
_ =>
{ # 2009-09-01 CrT: Spur-of-the-moment debug logic -- should
# find or create a standard print_path fun to use here. XXX BUGGO FIXME.
#
print "generic_lookup: first symbol in path does not name a package, path = '";
print_path (first ! rest)
where
fun print_path [] => ();
print_path [symbol] => { printf "%s" (symbol::name symbol); };
print_path (symbol ! rest) => { printf "%s::" (symbol::name symbol); print_path rest; };
end;
end;
print "'\n";
bug "generic_lookup.1";
};
esac
except
syx::UNBOUND
=
{ unbound_error (first, spmsg spath, err);
error_val;
};
syp::SYMBOL_PATH []
=>
bug "generic_lookup: syp::SYMBOL_PATH[]";
esac;
# Same as above, without the error message printing:
#
fun generic_lookup' (symbolmapstack, spath, out_bind, get_path, error_val, err)
=
case spath
#
syp::SYMBOL_PATH [id]
=>
out_bind (syx::get (symbolmapstack, id));
syp::SYMBOL_PATH (first ! rest)
=>
case (syx::get (symbolmapstack, first))
#
sxe::NAMED_PACKAGE a_package
=>
get_path (a_package, syp::SYMBOL_PATH rest, spath);
_ => bug "generic_lookup'.1";
esac;
syp::SYMBOL_PATH []
=>
bug "generic_lookup: syp::SYMBOL_PATH[]";
esac;
# Look up a variable or a constructor (complete path):
#
fun find_value_via_symbol_path (symbolmapstack, path, err) : vac::Variable_Or_Constructor
=
generic_lookup (symbolmapstack, path, out_val, mj::get_value_via_path, bogus_value, err)
where
fun out_val (sxe::NAMED_VARIABLE v) => vac::VARIABLE v;
out_val (sxe::NAMED_CONSTRUCTOR c) => vac::CONSTRUCTOR c;
out_val _ => bug "out_val";
end;
end;
# Same as above, without the error message printing:
#
fun find_value_via_symbol_path' (symbolmapstack, path, err) : vac::Variable_Or_Constructor
=
generic_lookup' (symbolmapstack, path, out_val, mj::get_value_via_path, bogus_value, err)
where
fun out_val (sxe::NAMED_VARIABLE v) => vac::VARIABLE v;
out_val (sxe::NAMED_CONSTRUCTOR c) => vac::CONSTRUCTOR c;
out_val _ => raise exception syx::UNBOUND;
end;
end;
# Look up a package
#
fun find_package_via_symbol_path (symbolmapstack, path, err) : mld::Package
=
generic_lookup (symbolmapstack, path, out_package, mj::get_package_via_path, bogus_package, err)
where
fun out_package (sxe::NAMED_PACKAGE a_package)
=>
a_package;
out_package _
=>
bug "find_package_via_symbol_path";
end;
end;
# Same as above, without printed error messages:
#
fun find_package_via_symbol_path' (symbolmapstack, path, err) : mld::Package
=
generic_lookup' (symbolmapstack, path, out_package, mj::get_package_via_path, bogus_package, err)
where
fun out_package (sxe::NAMED_PACKAGE a_package)
=>
a_package;
out_package _
=>
raise exception syx::UNBOUND;
end;
end;
# ** Look up a Package_Definition; used in elabsig.sml **
#
fun find_package_definition_via_symbol_path (symbolmapstack, path, err) : mld::Package_Definition
=
generic_lookup
(
symbolmapstack,
path,
out_sd,
mj::get_package_definition_via_path,
mld::CONSTANT_PACKAGE_DEFINITION bogus_package,
err
)
where
fun out_sd (sxe::NAMED_PACKAGE s)
=>
case s
#
mld::PACKAGE_API { an_api, stamppath }
=>
mld::VARIABLE_PACKAGE_DEFINITION (an_api, stamppath);
sv =>
mld::CONSTANT_PACKAGE_DEFINITION sv;
esac;
out_sd _
=>
bug "find_package_definition_via_symbol_path";
end;
end;
# Look up a generic package:
#
fun find_generic_via_symbol_path (symbolmapstack, path, err) : mld::Generic
=
generic_lookup (symbolmapstack, path, out_generic, mj::get_generic_via_path, bogus_g, err)
where
fun out_generic (sxe::NAMED_GENERIC fct) => fct;
out_generic _ => bug "find_generic_via_symbol_path";
end;
end;
# Look up a type constructor:
#
fun find_type_via_symbol_path (symbolmapstack, path, err): tdt::Type
=
generic_lookup
(
symbolmapstack,
path,
out_type,
mj::get_type_via_path,
tdt::ERRONEOUS_TYPE,
err
)
where
fun out_type (sxe::NAMED_TYPE type)
=>
type;
out_type _
=>
bug "find_type_via_symbol_path";
end;
end;
# Look up a type, check that arity is as expected **
#
fun find_type_via_symbol_path_and_check_arity (symbolmapstack, path, expected_arity, err)
=
case (find_type_via_symbol_path (symbolmapstack, path, err))
#
tdt::ERRONEOUS_TYPE => tdt::ERRONEOUS_TYPE; # Cannot go last! :-)
type => if (tj::arity_of_type type != expected_arity)
#
other_error("type constructor " +
(syp::to_string (cvp::invert_ipath (tj::namepath_of_type type))) +
" given " + (int::to_string expected_arity) + " arguments, wants "
+ (int::to_string (tj::arity_of_type type)), err);
tdt::ERRONEOUS_TYPE;
else
type;
fi;
esac;
# ** Look up an exception **
#
fun find_exception_via_symbol_path (symbolmapstack, path, err): tdt::Valcon
=
case (find_value_via_symbol_path (symbolmapstack, path, err))
#
vac::CONSTRUCTOR (c as tdt::VALCON { form=>(vh::EXCEPTION _), ... } )
=>
c;
vac::CONSTRUCTOR _
=>
{ other_error("found data constructor instead of exception", err);
vac::bogus_exception;
};
vac::VARIABLE _
=>
{ other_error("found variable instead of exception", err);
vac::bogus_exception;
};
esac;
}; # package find_in_symbolmapstack
end; # stipulate