## type-core-language-declaration-g.pkg
#
# For a higher-level overview see
#
# src/lib/compiler/front/typer/main/type-package-language-g.pkg#
# In this package we accept a deep-syntax Declaration
# and return that declaration rewritten to be fully typed,
# using the unification-based Hindley-Milner type-inference
# algorithm to propagate type information leaf-to-root.
#
# We also resolve overloaded literals and variables. # Overloaded literals include for example 1 which might be a byte-length int, a tagged int or a word-length int.
# This process is sort of a bag hung on the side of the
# language design; it is not well specified and does not
# fit in very well. Still, it is a real convenience --
# Ocaml lacks it and as a result must have (for example)
# a separate multiply op for every numeric type (ick!).
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib# Compiled by:
# src/lib/compiler/front/typer/typer.sublib### "You get what you give: Unloved code is ugly code."
stipulate
package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package lnd = line_number_db; # line_number_db is from src/lib/compiler/front/basics/source/line-number-db.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkgherein
api Type_Core_Language_Declaration {
#
type_core_language_declaration # SIDE-EFFECTS: Sets tdt::TYPEVAR_REF.ref_typevar (in unify_typoids) and vac::PLAIN_VARIABLE.vartypoid_ref (in generalize_*).
:
{ declaration: ds::Declaration, # The original declaration -- our primary input. (?)
symbolmapstack: syx::Symbolmapstack,
outside_all_lets: Bool,
error_function: err::Error_Function,
source_code_region: lnd::Source_Code_Region
}
-> ds::Declaration # The input declaration rewritten to be fully typed and free of overloaded literals and variables.
;
debugging: Ref( Bool );
};
end;
# Genericized to factor out dependencies on highcode...
stipulate
package cos = compile_statistics; # compile_statistics is from src/lib/compiler/front/basics/stats/compile-statistics.pkg package ctt = core_type_types; # core_type_types is from src/lib/compiler/front/typer-stuff/types/core-type-types.pkg package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package dsj = deep_syntax_junk; # deep_syntax_junk is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax-junk.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package id = inlining_data; # inlining_data is from src/lib/compiler/front/typer-stuff/basics/inlining-data.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.pkg package pds = prettyprint_deep_syntax; # prettyprint_deep_syntax is from src/lib/compiler/front/typer/print/prettyprint-deep-syntax.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package ppt = prettyprint_type; # prettyprint_type is from src/lib/compiler/front/typer/print/prettyprint-type.pkg package rol = resolve_overloaded_literals; # resolve_overloaded_literals is from src/lib/compiler/front/typer/types/resolve-overloaded-literals.pkg package rov = resolve_overloaded_variables; # resolve_overloaded_variables is from src/lib/compiler/front/typer/types/resolve-overloaded-variables.pkg package sta = stamp; # stamp is from src/lib/compiler/front/typer-stuff/basics/stamp.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 tc = typer_control; # typer_control is from src/lib/compiler/front/typer/basics/typer-control.pkg package td = typer_debugging; # typer_debugging is from src/lib/compiler/front/typer/main/typer-debugging.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package tyj = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package uds = unparse_deep_syntax; # unparse_deep_syntax is from src/lib/compiler/front/typer/print/unparse-deep-syntax.pkg package uj = unparse_junk; # unparse_junk is from src/lib/compiler/front/typer/print/unparse-junk.pkg package uty = unparse_type; # unparse_type is from src/lib/compiler/front/typer/print/unparse-type.pkg package uyt = unify_typoids; # unify_typoids is from src/lib/compiler/front/typer/types/unify-typoids.pkg package vac = variables_and_constructors; # variables_and_constructors is from src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg Pp = pp::Pp;
herein
# This generic is invoked (only) from:
#
# src/lib/compiler/front/semantic/types/type-core-language-declaration.pkg #
generic package type_core_language_declaration_g (
# ================================
inlining_data_says_it_is_pure: id::Inlining_Data -> Bool; # pure_info from src/lib/compiler/front/semantic/basics/inlining-junk.pkg inlining_data_to_my_type: id::Inlining_Data -> Null_Or( tdt::Typoid ); # inlining_data_to_my_type from src/lib/compiler/front/semantic/modules/generics-expansion-junk-parameter.pkg )
: (weak) Type_Core_Language_Declaration # Type_Core_Language_Declaration is from src/lib/compiler/front/typer/types/type-core-language-declaration-g.pkg {
stipulate
#
Symbolmapstack = syx::Symbolmapstack;
Error_Function = err::Error_Function;
--> = mtt::(-->);
# The following is support for tracking the
# lexical context in which type variables
# appear. We are interested in whether
# type variables are free or bound and also
# whether we are inside some let/stipulate
# construct or at top level.
#
# The two critical things we track are:
#
#
# outside_all_lets:
#
# TRUE iff we are not lexicallly # NB: A 'stipulate' statement is a 'let'
# within the scope of any "let" # construct, also { ... } code blocks and
# construct. # 'if'-statement 'then' and 'else' clauses.
#
# We need this because (for example)
# it is an error not to generalize # Generalization is discussed below.
# a type variable a top level but
# it is ok not to generalize one in
# a 'let' due to the "value restriction".
#
#
# fn_nesting:
#
# This is the number of fun/fn # 'lambdas', in fp jargon.
# definitions lexically enclosing us.
# This numbering starts at 0.
#
# We need this to support type agnosticism -- "polymorphism".
#
# Mythryl (and ML generally) implement
# what is sometimes called "let-polymorphism",
# in which (canonically) functions defined
# in 'let' constructs have their type variables
# 'generalized' to allow them to match different
# types in different invocations. For example
# {
# ...
# fun swap (a, b) = (b, a);
# ...
# p0 = swap ( 1 , 2 );
# p1 = swap ('1', '2');
# p2 = swap ("1", "2");
# ...
# };
#
# Here swap() is operating indifferently # "Don't-care polymorphism" and
# upon pairs of ints, chars and strings. # "parametric polymorphism" are two
# # more names for this kind of
# Making this typecheck requires a special # typeagnosticism.
# kludge. Here's how it works:
#
# o Instead of assigning 'swap' a normal # In fp jargon this is called a "type scheme".
# type, we assign it a "typescheme" # We represent them using TYPESCHEME records and
# (template) for a type, with holes # we represent the 'holes' with TYPESCHEME_ARG,
# where all the type variables should be. # both from ssrc/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg
#
# o Each time we come to a call to 'swap' # This copy-and-complete is implemented by
# we generate a fresh type for it by # tyj::instantiate_if_typescheme()
# making a copy of the typescheme and # from
# filling in all the holes with fresh # src/lib/compiler/front/typer-stuff/types/type-junk.pkg # type variables. #
#
# This way type inference is free to deduce
# a different type for each call to 'swap'.
#
# We refer to the process of replacing a
# type by such a type template as
# "type generalization".
#
# We implement this below, in
#
# generalize_pattern()
# generalize_type()
#
# However when doing such type variable
# generalization we must NOT generalize
# any type variables inherited from # For a more extended discussion
# enclosing scopes because the inherited # see Benjamin C Pierce's
# type variables encode important type # "Types and Programming Languages"
# constraints which will be lost if we # Chapter 22, in particular
# generalize them, allowing incorrect # page 333 rule 3.
# code to typecheck.
#
# We implement this restriction by
#
# 1) Tracking our current fn nesting level
# as we do syntactic dagwalks.
#
# 2) Tagging every type variable with
# the outermost fn nesting level
# mentioning it. (We refine this
# during the type unification pass.)
#
# 3) Generalizing only those variables
# defined at a deeper nesting level
# than our current dagwalk fn nesting
# level, which is to say variables
# introduced by 'let' constructs
# nested within the current fun/fn
# (if any), rather than inherited from
# scopes outside the 'let'.
#
# Free type variables not declared by the user
# are in general given a lexical nesting depth
# of 'infinity', represented by an arbitrary # E.g.: tyj::make_meta_typevar_and_type tdt::infinity;
# integer larger than any expected real lexical
# nesting depth.
#
# USER_TYPEVAR typevars
# are created with fn_nesting == infinity; # By make_user_typevar() in src/lib/compiler/front/typer-stuff/types/type-junk.pkg # this nesting depth can be reduced
# via unification.
#
# When we instantiate a typeagnostic
# type body we set all the META
# variables to fn_nesting == "infinity". # "infinity" being a kilomyriad, which
# # is to say 10000000. See types.pkg. :-)
#
#
# 8/18/92:
# Cleaned up syntax_treewalk_lexical_context
# "state machine" some and fixed bug #612.
#
Syntax_Treewalk_Lexical_Context
=
{
fn_nesting: Int,
outside_all_lets: Bool
};
# When we start a typechecking a dagwalk
# at the root of a syntax tree, this is
# our initial type variable context:
#
root_syntax_treewalk_lexical_context
=
{
fn_nesting => 0,
outside_all_lets => TRUE
};
# Note that we have entered the lexical scope
# of a 'let' equivalent construct.
# These include 'stipulate's, { ... } codeblocks and
# if-statement 'then' and 'else' clauses:
#
fun enter_let_scope { fn_nesting, outside_all_lets }
=
{
outside_all_lets => FALSE,
fn_nesting
};
# Note that we have entered the lexical scope
# of a fun/fn or equivalent construct:
#
fun enter_fn_scope { fn_nesting, outside_all_lets }
=
{
if *uty::debugging
printf "enter_fn_scope bumping fn_nesting from %d to %d\n" fn_nesting (fn_nesting + 1);
fi;
{
fn_nesting => fn_nesting + 1,
outside_all_lets
};
};
herein
# Debug support:
say = control_print::say;
# debugging = tc::type_core_language_declaration_g_debugging; # REF FALSE
# internals = REF FALSE;
debugging = log::debugging;
internals = log::debugging;
generalize_mutually_recursive_functions
=
tc::generalize_mutually_recursive_functions; # REF FALSE
#
fun if_debugging_say (msg: String)
=
if *debugging
say msg;
say "\n";
fi;
debug_print = (\\ x = td::debug_print debugging x);
#
fun bug msg = err::impossible("TypeCheck: " + msg);
#
fun print_callstack
(msg: String)
(callstack: List(String))
=
{ printf "%s: callstack(%d) == " msg (list::length callstack);
apply {. printf " -> %s" #string; } (reverse callstack);
printf "\n";
};
is_value = tyj::is_value { inlining_data_says_it_is_pure };
infix my 9 sub ;
infix my --> ;
print_depth = control_print::print_depth;
#
fun ref_new_valcon (tdt::VALCON { name, is_constant, form, typoid, signature, is_lazy } )
=
tdt::VALCON
{
typoid => mtt::ref_pattern_typoid,
name,
is_constant,
form,
signature,
is_lazy
};
exception NOT_THERE;
#
fun message ( msg, mode: unify_typoids::Unify_Fail )
=
string::cat [ msg, " [", unify_typoids::fail_message mode, "]" ];
# Here is the heart of the compiler's type inference engine.
#
# This is also where we implement type agnosticism
# by generalizing USER_TYPEVAR and META_TYPEVAR
# types to TYPESCHEME_ARG types whenever permitted
# by the "value restriction" as implemented by is_value() in
#
# src/lib/compiler/front/typer-stuff/types/type-junk.pkg #
# We are called (only) from type_declaration'() in
#
# src/lib/compiler/front/typer/main/type-package-language-g.pkg #
# We delegate actual type unification to unify_typoids() in
#
# src/lib/compiler/front/typer/types/unify-typoids.pkg #
# A light overview of Hindley-Milner type inference may be found here:
# http://en.wikipedia.org/wiki/Type_inference
#
# A more detailed treatment may be found in the
# Types and Programming Languages
# text by Benjamin C Pierce, chapter 22.
#
fun type_core_language_declaration # PUBLIC. (The only one in this file.)
{ # SIDE-EFFECTS: Sets tdt::TYPEVAR_REF.ref_typevar (in unify_typoids) and vac::PLAIN_VARIABLE.vartypoid_ref (in generalize_*).
declaration: ds::Declaration,
symbolmapstack: Symbolmapstack, # symbolmapstack is needed only for debug printouts, not for core algorithmic purposes.
#
outside_all_lets: Bool,
error_function: Error_Function,
source_code_region: ds::Source_Code_Region
}
: ds::Declaration
=
{
if_debugging_unparse_declaration ("\ntype_core_language_declaration: MID, just before calling do_declaration: declaration unparse is: ", declaration );
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration: MID, just before calling do_declaration: declaration prettyprint is: ", (declaration,100));
if_debugging_say "\ntype_core_language_declaration: NEWCODE is set.\n";
if (not (dsj::core_declaration_contains_overloaded_variable declaration))
if_debugging_say "\ntype_core_language_declaration: NEWCODE is set but declaration does NOT contain an overloaded variable.\n";
# In the absence of overloaded variables,
# the old, simple approach is fine:
#
declaration
=
do_declaration (
#
declaration,
outside_all_lets ?? root_syntax_treewalk_lexical_context
:: enter_let_scope root_syntax_treewalk_lexical_context,
source_code_region,
[]
);
if_debugging_unparse_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]: XYZZ pre-overload-resolution declaration unparse is:\n", declaration);
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]: XYZZ pre-overload-resolution declaration pyprint is:\n", (declaration,100));
if_debugging_say ("\ntype_core_language_declaration: calling resolve_all_overloaded_literals ... [type-core-language-declaration-g.pkg]\n");
r1 = resolve_all_overloaded_literals (); if_debugging_say ("\ntype_core_language_declaration: calling resolve_all_overloaded_variables ... [type-core-language-declaration-g.pkg]\n");
r2 = resolve_all_overloaded_variables symbolmapstack;
if_debugging_unparse_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]: BOT PLUXX. pre-hack declaration unparse is:\n", declaration);
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]: BOT PLUXX. pre-hack declaration prettyprint is:\n", (declaration,100));
if_debugging_unparse_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]: BOT PLUGH. transformed declaration unparse is:\n", declaration);
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]: BOT PLUGH. transformed declaration prettyprint is:\n", (declaration,100));
if_debugging_say "\n^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^";
if_debugging_say "============= type_core_language_declaration/BOTTOM =============\n";
declaration;
else
if_debugging_say "\ntype_core_language_declaration: NEWCODE is set and declaration DOES contain an overloaded variable.\n";
# When overloaded variables are present, we do a couple of passes
# to replace them all with the appropriate variants, then proceed
# as though they never existed:
if_debugging_unparse_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/AAA: declaration unparse is:\n", declaration);
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/AAA: declaration prettyprint is:\n", (declaration,100));
undo_log := THE []; # Enable undo-log functionality for first pass: Purpose of first pass is *only* to resolve overloaded variables, all other changes will be undone.
if_debugging_say "\ntype_core_language_declaration/NEWCODE calling do_declaration(declaration) (1st)...\n";
do_declaration ( # Now, we do type deduction on it to select the type-appropriate variant for each overloaded variable.
#
declaration,
outside_all_lets ?? root_syntax_treewalk_lexical_context
:: enter_let_scope root_syntax_treewalk_lexical_context,
source_code_region,
[]
);
if_debugging_say "\ntype_core_language_declaration/NEWCODE back from do_declaration(declaration) (1st)...\n";
if_debugging_unparse_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/BBB: declaration unparse is:\n", declaration);
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/BBB: declaration prettyprint is:\n", (declaration,100));
if_debugging_say "\ntype_core_language_declaration/NEWCODE calling resolve_all_overloaded_variables...\n";
resolved_overloaded_variables
=
resolve_all_overloaded_variables symbolmapstack # symbolmapstack is needed only for debug printout etc.
:
List(vac::Variable);
if_debugging_say "\ntype_core_language_declaration/NEWCODE back from resolve_all_overloaded_variables...\n";
if_debugging_unparse_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/CCC: declaration unparse is:\n", declaration);
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/CCC: declaration prettyprint is:\n", (declaration,100));
if_debugging_say "\ntype_core_language_declaration/NEWCODE running undo_log...\n";
apply (\\ f = f()) (the *undo_log); # Execute undo thunks in last-in first-out order to restore 'declaration' to original state.
if_debugging_say "\ntype_core_language_declaration/NEWCODE done running undo_log...\n";
if_debugging_unparse_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/DDD: declaration unparse is:\n", declaration);
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/DDD: declaration prettyprint is:\n", (declaration,100));
undo_log := NULL; # Disable undo-log functionality for second pass.
if_debugging_say "\ntype_core_language_declaration/NEWCODE calling replace_overloaded_variables_in_core_declaration...\n";
declaration # Now we plug in the appropriate overloaded-variable variants for each overloaded variable in the original declaration tree.
=
dsj::replace_overloaded_variables_in_core_declaration
declaration
resolved_overloaded_variables;
if_debugging_say "\ntype_core_language_declaration/NEWCODE back from replace_overloaded_variables_in_core_declaration...\n";
if_debugging_unparse_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/EEE: declaration unparse is:\n", declaration);
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/EEE: declaration prettyprint is:\n", (declaration,100));
if_debugging_say "\ntype_core_language_declaration/NEWCODE calling do_declaration(declaration) (2nd)...\n";
declaration # Now we process the patched original declaration tree just as though it had never contained any overloaded variables.
=
do_declaration (
#
declaration,
outside_all_lets ?? root_syntax_treewalk_lexical_context
:: enter_let_scope root_syntax_treewalk_lexical_context,
source_code_region,
[]
);
if_debugging_say "\ntype_core_language_declaration/NEWCODE back from do_declaration(declaration) (2nd)...\n";
if_debugging_unparse_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/FFF: declaration unparse is:\n", declaration);
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration [type-core-language-declaration-g.pkg]/NEWCODE/O/FFF: declaration prettyprint is:\n", (declaration,100));
if_debugging_say "\ntype_core_language_declaration/NEWCODE calling resolve_all_overloaded_literals ... [type-core-language-declaration-g.pkg]\n";
r1 = resolve_all_overloaded_literals ();
if_debugging_say "\ntype_core_language_declaration/NEWCODE back from resolve_all_overloaded_literals ... [type-core-language-declaration-g.pkg]\n";
declaration;
fi;
}
where
undo_log = REF (NULL: Null_Or(List(Void -> Void))); # When non-NULL, undo_log accumulates a list of thunks which will undo everything done by do_declaration() call.
#
fun maybe_note_ref_in_undo_log #
( # We make undo_log an explicit argument for consistency with usage in (e.g.) src/lib/compiler/front/typer/types/unify-typoids.pkg undo_log: Ref (Null_Or(List(Void -> Void))), # When non-NULL, *undo_log accumulates a list of thunks which will undo everything done by do_declaration() call.
ref: Ref(X) # If we're maintaining the undo_log, add an entry to undo uncoming assignment to ref.
)
=
case *undo_log
#
THE log => { oldval = *ref;
#
undo_log := THE ((\\ () = ref := oldval) ! log);
};
NULL => ();
esac;
(rol::make_overloaded_literal_resolver () ) -> { note_overloaded_literal, resolve_all_overloaded_literals };
(rov::make_overloaded_variable_resolver (inlining_data_to_my_type, undo_log)) -> { note_overloaded_variable, resolve_all_overloaded_variables };
prettyprint_named_recursive_value = pds::prettyprint_named_recursive_value (syx::empty, NULL);
prettyprint_declaration = pds::prettyprint_declaration (syx::empty, NULL);
prettyprint_expression = pds::prettyprint_expression (syx::empty, NULL);
prettyprint_pattern = pds::prettyprint_pattern syx::empty;
prettyprint_typoid = ppt::prettyprint_typoid symbolmapstack;
unparse_typoid = uty::unparse_typoid symbolmapstack;
unparse_typevar_ref = uty::unparse_typevar_ref symbolmapstack;
unparse_pattern = uds::unparse_pattern symbolmapstack;
unparse_expression = uds::unparse_expression (symbolmapstack, NULL);
unparse_rule = uds::unparse_rule (symbolmapstack, NULL);
unparse_named_value = uds::unparse_named_value (symbolmapstack, NULL);
unparse_recursively_named_value = uds::unparse_recursively_named_value (symbolmapstack, NULL);
unparse_declaration
=
(\\ stream
=
\\ d = uds::unparse_declaration
(symbolmapstack, NULL)
stream
(d, *print_depth)
);
#
/* */ fun if_debugging_unparse_declaration (msg, declaration)
=
if *debugging
if *internals td::with_internals (\\ () = td::debug_print debugging (msg, unparse_declaration, declaration));
else td::debug_print debugging (msg, unparse_declaration, declaration) ;
fi;
fi;
#
/* */ fun if_debugging_unparse_typoid (msg, type)
=
if *debugging
if *internals td::with_internals (\\ () = td::debug_print debugging (msg, unparse_typoid, type));
else td::debug_print debugging (msg, unparse_typoid, type) ;
fi;
fi;
#
/* */ fun if_debugging_prprint_typoid (msg, type)
=
if *debugging
if *internals td::with_internals (\\ () = td::debug_print debugging (msg, prettyprint_typoid, type));
else td::debug_print debugging (msg, prettyprint_typoid, type) ;
fi;
fi;
#
/* */ fun if_debugging_unparse_typevar_ref (msg, typevar_ref)
=
if *debugging # Without this 'if' (and the matching one in unify_typoids), compiling the compiler takes 5X as long! :-)
if *internals td::with_internals (\\ () = td::debug_print debugging (msg, unparse_typevar_ref, typevar_ref));
else td::debug_print debugging (msg, unparse_typevar_ref, typevar_ref) ;
fi;
fi;
#
/* */ fun if_debugging_unparse_pattern (msg, pattern)
=
if *debugging
if *internals td::with_internals (\\ () = td::debug_print debugging (msg, unparse_pattern, pattern));
else td::debug_print debugging (msg, unparse_pattern, pattern) ;
fi;
fi;
#
/* */ fun if_debugging_unparse_expression (msg, expression)
=
if *debugging
if *internals td::with_internals (\\ () = td::debug_print debugging (msg, unparse_expression, expression));
else td::debug_print debugging (msg, unparse_expression, expression) ;
fi;
fi;
#
/* */ fun if_debugging_prettyprint_expression (msg, expression)
=
if *debugging
if *internals td::with_internals (\\ () = td::debug_print debugging (msg, prettyprint_expression, expression));
else td::debug_print debugging (msg, prettyprint_expression, expression) ;
fi;
fi;
#
/* */ fun if_debugging_prettyprint_pattern (msg, pattern)
=
if *debugging
if *internals td::with_internals (\\ () = td::debug_print debugging (msg, prettyprint_pattern, pattern));
else td::debug_print debugging (msg, prettyprint_pattern, pattern) ;
fi;
fi;
#
/* */ fun if_debugging_prettyprint_declaration (msg, declaration)
=
if *debugging
if *internals td::with_internals (\\ () = td::debug_print debugging (msg, prettyprint_declaration, declaration));
else td::debug_print debugging (msg, prettyprint_declaration, declaration) ;
fi;
fi;
#
/* */ fun if_debugging_prettyprint_named_recursive_value (msg, val)
=
if *debugging
if *internals td::with_internals (\\ () = td::debug_print debugging (msg, prettyprint_named_recursive_value, val));
else td::debug_print debugging (msg, prettyprint_named_recursive_value, val) ;
fi;
fi;
# This is a simple wrapper for unify_typoids(),
# used all through this file.
#
# 'typoid1' and 'typoid2' are the only
# arguments of consequence; the rest
# are just diagnostic printing support:
#
fun unify_typoids_and_handle_errors # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
{
typoid1, name1, # typoid1: tdt::Typoid, name1: String
typoid2, name2, # typoid2: tdt::Typoid, name2: String
message => m,
source_code_region,
unparse_phrase, # prettyprint::String -> (X, Int) -> Void
phrase_name, # String
phrase, # X; X here and above is one of deep syntax Case_Pattern, Expression, ...
callstack,
undo_log
}
=
{
# More annoying than helpful:
# if *debugging
# printf "type-core-language-declaration-g.pkg:\
# \ unify_typoids_and_handle_errors: calling unify_typoids name1 %s name2 %s message %s\n" name1 name2 m;
# fi;
uyt::unify_typoids # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
(
name1, name2,
typoid1, typoid2,
"unify_typoids_and_handle_errors" ! callstack,
undo_log
);
TRUE;
}
except
uyt::UNIFY_TYPOIDS mode
=
{ error_function source_code_region
err::ERROR
(message (m, mode))
(\\ pp
=
{ uty::reset_unparse_type();
len1 = size name1;
len2 = size name2;
blanks = " ";
pad1 = substring (blanks, 0, int::max (0, len2-len1));
pad2 = substring (blanks, 0, int::max (0, len2-len1));
m = if (m=="")
name1 + " and " + name2 + " don't agree";
else m;
fi;
if (name1 != "")
pp.newline();
pp.lit (name1 + ": " + pad1);
unparse_typoid pp typoid1;
fi;
if (name2 != "")
pp.newline();
pp.lit (name2 + ": " + pad2);
unparse_typoid pp typoid2;
fi;
if (phrase_name != "")
pp.newline();
pp.lit ("in " + phrase_name + ":");
pp::break pp { blanks=>1, indent_on_wrap=>2 };
unparse_phrase pp (phrase,*print_depth);
fi;
}
);
FALSE;
};
if_debugging_say "\n============= type_core_language_declaration/TOP ============= [type-core-language-declaration-g.pkg]";
if_debugging_say "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv\n";
if_debugging_say ("type_core_language_declaration: outside_all_lets = " + bool::to_string outside_all_lets);
if_debugging_unparse_declaration ("\ntype_core_language_declaration/TOP: declaration unparse = [type-core-language-declaration-g.pkg]", declaration);
if_debugging_prettyprint_declaration ("\ntype_core_language_declaration/TOP: declaration prettyprint = [type-core-language-declaration-g.pkg]", (declaration,100));
# This is the core routine responsible for marking
# a pattern variable as typeagnostic ("polymorphic").
#
# Our first argument below is the most important;
# it is from a ds::VARIABLE_IN_PATTERN.
# The critical part of it is the 'vartypoid_ref' ref:
# we will overwrite it with a generalized
# version of itself -- a
# tdt::TYPESCHEME_TYPOID { ... }
# record wrapping a type scheme -- and then return
# the list of generalized type variables as our result.
#
# We get called frome exactly one place,
# in generalize_pattern'() in generalize_pattern().
#
fun generalize_type # SIDE-EFFECT: Sets vac::PLAIN_VARIABLE.vartypoid_ref
(
vac::PLAIN_VARIABLE { vartypoid_ref, path, ... }: vac::Variable,
user_typevar_refs: List( tdt::Typevar_Ref ), # *NAMED_VALUE.typevars -- X, Y, Z ... from a function clause pattern or such.
syntax_treewalk_lexical_context: Syntax_Treewalk_Lexical_Context,
generalize: Bool, # Result of tyj::is_value() -- TRUE iff the "value restriction" permits generalizing this type.
source_code_region: ds::Source_Code_Region,
callstack: List(String) # Debug support.
)
: List( tdt::Typevar_Ref ) # These will actually always be tdt::META_TYPEVAR or tdt::USER_TYPEVAR.
=>
{
if *debugging
print_callstack "\n============= generalize_type/TOP =============" callstack;
say ( "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv [type-core-language-declaration-g.pkg]\n\n");
say ("generalize_type: " + symbol_path::to_string path);
say "\nuser_typevar_refs: ";
apply unparse_typevar_ref user_typevar_refs
where
/* */ fun unparse_typevar_ref typevar_ref
=
if_debugging_unparse_typevar_ref ("", typevar_ref);
end;
printf "\ngeneralize is %s\n" (generalize ?? "TRUE" :: "FALSE");
printf "lexical context: fn_nesting d= %d outside_all_lets b= %s\n" syntax_treewalk_lexical_context.fn_nesting (syntax_treewalk_lexical_context.outside_all_lets ?? "TRUE" :: "FALSE");
fi;
failure = REF FALSE;
# Function to create dummy-type generators
# used to resolve ungeneralizable free
# type variables in typechecking::generalize_type:
#
make_dummy = { syntax_treewalk_lexical_context.outside_all_lets
??
make_dummytype_generator()
::
make_dummy'; # Shouldn't be called.
}
where
#
fun make_dummy' ()
=
mtt::void_typoid;
# stamp is from src/lib/compiler/front/typer-stuff/basics/stamp.pkg fun make_dummytype_generator () : Void -> tdt::Typoid
=
{ count = REF 0;
#
fun next ()
=
{ count := *count + 1;
*count;
};
#
fun next_type ()
=
{ name = "X" + int::to_string (next ());
#
tdt::TYPCON_TYPOID (
#
tdt::SUM_TYPE
{
stamp => sta::make_static_stamp name,
namepath => ip::INVERSE_PATH [sy::make_type_symbol name],
arity => 0,
is_eqtype => REF tdt::e::NO,
kind => tdt::ABSTRACT ctt::bool_type,
stub => NULL
},
[]
);
};
next_type;
};
end;
typescheme_arg_slots_allocated # Tracks number of type variables bound. This will wind up being the typescheme arity.
=
REF 0;
#
fun allot_typescheme_arg_slot ()
=
{ slot = *typescheme_arg_slots_allocated;
#
typescheme_arg_slots_allocated
:=
slot+1;
slot;
};
#
fun is_local_function_typevar_ref ref_typevar # Check a typevar_ref for membership in our 'user_typevar_refs' parameter.
=
is_member user_typevar_refs
where
fun is_member (user_typevar_ref ! rest)
=>
tyj::same_typevar_ref (ref_typevar, user_typevar_ref) # NB: This compares the refcells, NOT their contents!
or
is_member rest;
is_member [] => FALSE;
end;
end;
typescheme_eqflags # Track which of the below type variables need to be of equality type.
= # This list will always be the same length as the next.
REF ([]: tdt::Typescheme_Eqflags); # Possibly they should be combined.
# In this association list we track the
# tdt::TYPESCHEME_ARG slots of variables
# we've already generalized, to avoid assigning
# two slots to one variable.
#
# The keys in this list are USER_TYPEVAR
# and META_TYPEVAR type variables; the
# corresponding values are the
# tdt::TYPESCHEME_ARG types (slot numbers)
# we create for them.
#
# ASSERTION: There are no duplicate typevars
# in domain of generalized_typevars.
#
generalized_typevar_ref_types
=
REF ([]: List( ( tdt::Typevar_Ref, # This will be REF( tdt::META_TYPEVAR | tdt::USER_TYPEVAR )
tdt::Typoid # This will actually always be a tdt::TYPESCHEME_ARG.
) ) );
#
fun note_generalized_typevar_ref_type # Add an entry to above list.
(
typevar_ref: tdt::Typevar_Ref, # This will reference a tdt::META_TYPEVAR or tdt::USER_TYPEVAR
sometype: tdt::Typoid # This will actually always be a tdt::TYPESCHEME_ARG.
)
=
{
if *debugging
if_debugging_unparse_typevar_ref ("\nnote_generalized_typevar_ref_type adding typevar_ref [type-core-language-declaration-g.pkg]: ", typevar_ref);
if_debugging_unparse_typoid (" with type (unparse)", sometype);
if_debugging_prprint_typoid (" with type (prprint)", sometype);
fi;
generalized_typevar_ref_types
:=
(typevar_ref, sometype)
!
*generalized_typevar_ref_types;
};
#
fun find_generalized_typevar_ref_type typevar_ref # Search above list. Return key's value if found, otherwise raise NOT_THERE.
=
search *generalized_typevar_ref_types
where
fun search ((typevar_ref', typescheme_arg) ! rest)
=>
tyj::same_typevar_ref (typevar_ref, typevar_ref')
??
typescheme_arg
::
search rest;
search [] => raise exception NOT_THERE;
end;
end;
# Make a type typeagnostic.
# This mainly means replacing both of
# META_TYPEVAR
# USER_TYPEVAR
# by
# tdt::TYPESCHEME_ARG
# wherever permitted by the "value restriction"
# as implemented by tyj::is_value() and passed
# to us via the 'generalize' parameter.
#
# We construct and return a Type result
# to replace our Type argument, but along
# the way we also side-effect various
# typevars etc in the expression, so
# this code is far from pure:
#
fun generalize_type' # SIDE-EFFECT: SETS vac::PLAIN_VARIABLE.vartypoid_ref
(typoid: tdt::Typoid)
: tdt::Typoid
=
case typoid
#
tdt::TYPEVAR_REF (typevar_ref # This is the focal case for this function.
as { id, # The remaining cases are mostly corner cases
ref_typevar as REF (tdt::META_TYPEVAR { fn_nesting, eq }) } # and recursive descent to reach this case.
)
=>
{ if *debugging
printf "generalize_type'/META fn_nesting d=%d eq b=%s generalize b=%s\n"
fn_nesting (eq ?? "TRUE" :: "FALSE") (generalize ?? "TRUE" :: "FALSE");
fi;
result
=
if (fn_nesting > syntax_treewalk_lexical_context.fn_nesting) # If type variable is not constrained by contexts outside this 'let'.
#
if generalize # If 'value restriction' permits generalization of this type variable.
#
if_debugging_say ("\ngeneralize_type'/META_TYPEVAR: converting META to TYPESCHEME_ARG [type-core-language-declaration-g.pkg]\n");
find_generalized_typevar_ref_type typevar_ref # If we've already assigned this META variable a TYPESCHEME_ARG slot, return that as our replacement for it.
except
NOT_THERE
=
{ new_typescheme_slot_arg # Assign a new type scheme slot for this META type variable,
=
tdt::TYPESCHEME_ARG( allot_typescheme_arg_slot() );
if_debugging_say ("\ngeneralize_type'/META_TYPEVAR: converting META to TYPESCHEME_ARG by allocating new TYPESCHEME_ARG [type-core-language-declaration-g.pkg]\n");
#
typescheme_eqflags # Remember whether this TYPESCHEME_ARG typevar must resolve to an equality type.
:=
eq ! *typescheme_eqflags;
note_generalized_typevar_ref_type # Note new typescheme slot for future reference.
(typevar_ref, new_typescheme_slot_arg);
new_typescheme_slot_arg; # Return new typescheme slot as our replacement for the META type variable.
};
else # !generalize
if syntax_treewalk_lexical_context.outside_all_lets
#
typevar = make_dummy ();
maybe_note_ref_in_undo_log (undo_log, ref_typevar);
ref_typevar := tdt::RESOLVED_TYPEVAR typevar; if_debugging_say ("\ngeneralize_type'/META_TYPEVAR: generalize FALSE so converting META to RESOLVED_TYPEVAR dummy [type-core-language-declaration-g.pkg]\n");
failure := TRUE;
typevar;
else
if *tc::value_restriction_local_warn
#
error_function source_code_region err::WARNING
( "type variable not generalized in local declaration due to 'value restriction': "
+
(uty::typevar_ref_printname typevar_ref)
)
err::null_error_body;
fi;
maybe_note_ref_in_undo_log (undo_log, ref_typevar);
ref_typevar # Reset fn_nesting to prevent later incorrect generalization inside a fun/fn expression. See typechecking test.pkg
:=
tdt::META_TYPEVAR
{ eq,
fn_nesting => syntax_treewalk_lexical_context.fn_nesting
};
if_debugging_say ("\ngeneralize_type'/META_TYPEVAR: generalize FALSE, resetting fn_nesting to prevent incorrect generalization [type-core-language-declaration-g.pkg]\n");
typoid; # Return our (modified) input argument as our result.
fi;
fi;
elif (fn_nesting == 0 and syntax_treewalk_lexical_context.outside_all_lets)
# ASSERT: failed generalization at fn_nesting 0.
# see bug 1066.
if_debugging_say ("\ngeneralize_type'/META_TYPEVAR: generalize FALSE, fn_nesting==0, changing to RESOLVED_TYPEVAR dummy [type-core-language-declaration-g.pkg]\n");
find_generalized_typevar_ref_type typevar_ref
except
NOT_THERE
=
{ new = make_dummy ();
failure := TRUE;
maybe_note_ref_in_undo_log (undo_log, ref_typevar);
ref_typevar := tdt::RESOLVED_TYPEVAR new;
new;
};
else
typoid;
fi;
result;
};
tdt::TYPEVAR_REF (typevar_ref as { id, ref_typevar => REF (tdt::INCOMPLETE_RECORD_TYPEVAR { fn_nesting, eq, known_fields => [ (lab, _) ] } ) })
=>
if ( ( fn_nesting > syntax_treewalk_lexical_context.fn_nesting
and (generalize or syntax_treewalk_lexical_context.outside_all_lets)
)
or
( fn_nesting == 0
and
syntax_treewalk_lexical_context.outside_all_lets
)
)
error_function source_code_region err::ERROR
(string::cat
[ "unresolved record type\n\
\ (Don't know what fields it has beyond .", # Originally said 'flex record'.
sy::name lab,
")"
]
)
err::null_error_body;
if_debugging_say ("\ngeneralize_type': converting INCOMPLETE_RECORD_TYPEVAR to WILDCARD [type-core-language-declaration-g.pkg]\n");
tdt::WILDCARD_TYPOID;
else
if_debugging_say ("\ngeneralize_type': leaving INCOMPLETE_RECORD_TYPEVAR as-is [type-core-language-declaration-g.pkg]\n");
typoid;
fi;
tdt::TYPEVAR_REF (typevar_ref as { id, ref_typevar => REF (tdt::INCOMPLETE_RECORD_TYPEVAR { fn_nesting, eq, known_fields } ) } )
=>
if ( ( fn_nesting > syntax_treewalk_lexical_context.fn_nesting
and (generalize or syntax_treewalk_lexical_context.outside_all_lets)
)
or ( fn_nesting == 0
and
syntax_treewalk_lexical_context.outside_all_lets
)
)
known_fields' = string::cat (list::map (\\ (label, _) = sy::name label + " ") known_fields);
error_function source_code_region err::ERROR # Originally said "flex record".
( "unresolved record type: Know only fields "
+ known_fields'
+ " but need to know the names of ALL the fields in this context."
)
(\\ pp
=
{ uty::reset_unparse_type();
pp.newline();
pp.lit "type: ";
unparse_typoid pp typoid;
}
);
tdt::WILDCARD_TYPOID;
else
typoid;
fi;
tdt::TYPEVAR_REF { id, ref_typevar => REF (tdt::RESOLVED_TYPEVAR typoid) }
=>
{
if_debugging_unparse_typoid ("\ngeneralize_type'/RESOLVED_TYPEVAR: generalizing resolved type variable of type (unparse): [type-core-language-declaration-g.pkg]\n", typoid);
if_debugging_prprint_typoid ("\ngeneralize_type'/RESOLVED_TYPEVAR: generalizing resolved type variable of type (prprint): [type-core-language-declaration-g.pkg]\n", typoid);
# Drop from the type the now-useless prefix
# tdt::TYPEVAR_REF (REF (tdt::RESOLVED_TYPEVAR
# Process and return the remainder of the type:
#
generalize_type' typoid;
};
tdt::TYPEVAR_REF (typevar_ref as { id, ref_typevar as REF (tdt::USER_TYPEVAR { name, fn_nesting, eq } ) } )
=>
{ if *debugging printf "generalize_type'/USER_TYPEVAR [type-core-language-declaration-g.pkg]: %s fn_nesting==%d eq==%s\n" (sy::name name) fn_nesting (eq ?? "TRUE" :: "FALSE"); fi;
# We're looking at a type variable X or Y in an
# expression like fun foo (x: X) = ... and
# wondering if it is ok to generalize.
# If it isn't on the list of type variables
# used in the current function's pattern
# clause(s) (parameter expressions), we have
# no business messing with it:
#
if (not (is_local_function_typevar_ref typevar_ref)) if_debugging_say "is not local";
#
typoid; # This USER_TYPEVAR does not belong to us, so we should not generalize it.
else if_debugging_say " is local";
# This USER_TYPEVAR -does- belong
# to us, so we can (maybe) generalize it:
# If this type variable is mentioned in an
# enclosing lexical context (fun/fn), it
# encodes type constraints that would be
# lost if we generalized it, allowing
# incorrect code to typecheck.
if ( fn_nesting > syntax_treewalk_lexical_context.fn_nesting # if external scope references do not forbid generalization...
and
generalize # ... and if "value restriction" does not forbid generalization...
)
# ... then we are GO to generalize this type variable.
if_debugging_say " is generalizable, replacing USER_TYPEVAR by TYPESCHEME_ARG [type-core-language-declaration-g.pkg]";
find_generalized_typevar_ref_type typevar_ref # If we've already generalized it, use assigned typescheme slot.
except
NOT_THERE
=
{ # Need to assign a fresh typescheme slot, then note and return it.
new_typescheme_slot_arg
=
tdt::TYPESCHEME_ARG (allot_typescheme_arg_slot());
typescheme_eqflags # Remember whether this new type variable resolve to an equality type.
:=
eq ! *typescheme_eqflags;
note_generalized_typevar_ref_type
( typevar_ref,
new_typescheme_slot_arg
);
new_typescheme_slot_arg;
};
else
printf "generalize_type'/USER_TYPEVAR: %s fn_nesting==%d syntax_treewalk_lexical_context.fn_nesting==%d\n"
(sy::name name) fn_nesting syntax_treewalk_lexical_context.fn_nesting;
error_function source_code_region err::ERROR
( "Explicit type variable cannot be generalized at its declaration point: "
+
(uty::typevar_ref_printname typevar_ref)
)
err::null_error_body;
maybe_note_ref_in_undo_log (undo_log, ref_typevar);
ref_typevar := tdt::RESOLVED_TYPEVAR tdt::WILDCARD_TYPOID;
tdt::WILDCARD_TYPOID;
fi;
fi;
};
( tdt::TYPEVAR_REF { id, ref_typevar as REF (tdt::LITERAL_TYPEVAR _) }
| tdt::TYPEVAR_REF { id, ref_typevar as REF (tdt::OVERLOADED_TYPEVAR _) }
)
=>
typoid;
tdt::TYPCON_TYPOID (typ, args)
=>
{ if_debugging_unparse_typoid ("\ngeneralize_type'/TYPCON_TYPE: generalizing constructor type (unparse): [type-core-language-declaration-g.pkg]\n", typoid);
if_debugging_prprint_typoid ("\ngeneralize_type'/TYPCON_TYPE: generalizing constructor type (prprint): [type-core-language-declaration-g.pkg]\n", typoid);
#
tdt::TYPCON_TYPOID (typ, map generalize_type' args);
};
tdt::WILDCARD_TYPOID
=>
tdt::WILDCARD_TYPOID;
_ => {
yes = REF TRUE;
td::with_internals (\\ () = td::debug_print yes ("unparsing bad arg to generalize_type:", unparse_typoid, typoid));
td::with_internals (\\ () = td::debug_print yes ("pprinting bad arg to generalize_type:", prettyprint_typoid, typoid));
# typoid;
bug "generalize_type -- bad arg";
};
esac; # fun generalize_type'
if_debugging_unparse_typoid ("\ngeneralize_type: vartypoid_ref as given to generalize_type' (unparse): [type-core-language-declaration-g.pkg]", *vartypoid_ref);
if_debugging_prprint_typoid ("\ngeneralize_type: vartypoid_ref as given to generalize_type' (prprint): [type-core-language-declaration-g.pkg]", *vartypoid_ref);
typescheme_body = generalize_type' *vartypoid_ref;
if_debugging_unparse_typoid ("\ngeneralize_type: vartypoid_ref as converted by generalize_type' (unparse): [type-core-language-declaration-g.pkg]", typescheme_body);
if_debugging_prprint_typoid ("\ngeneralize_type: vartypoid_ref as converted by generalize_type' (prprint): [type-core-language-declaration-g.pkg]", typescheme_body);
generalized_typevar_refs
=
map #1 (reverse *generalized_typevar_ref_types);
if_debugging_say ("\ngeneralize_type: running hack to eliminate user_bound variables. [type-core-language-declaration-g.pkg]\n");
apply eliminate_user_bound_typevars # Turn user bound typevars (USER_TYPEVAR) into ordinary META_TYPEVARs.
generalized_typevar_refs
where # A hack to eliminate all user bound type variables --zsh
# ZHONG?: is this still necessary? -- David B MacQueen
# 2014-01-15 CrT: Apparently it is -- commenting out this block and doing a compile cycle produces:
# Error: Compiler bug: translate_deep_syntax_to_lambdacode: unexpected typevar MACRO_EXPANDED in translate_pattern_expression
fun eliminate_user_bound_typevars
{
id,
ref_typevar as REF (tdt::USER_TYPEVAR { fn_nesting, eq, ... } )
}
=>
{ if *debugging printf "generalize_type: eliminate_user_bound_typevars: converting USER_TYPEVAR id%d to META_TYPEVAR. [type-core-language-declaration-g.pkg]\n" id; fi;
maybe_note_ref_in_undo_log (undo_log, ref_typevar);
#
ref_typevar := tdt::META_TYPEVAR { fn_nesting, eq };
};
eliminate_user_bound_typevars _
=>
();
end;
end;
if *failure
# if_debugging_say ("\ngeneralize_type: type vars left ungeneralized because of value restriction. [type-core-language-declaration-g.pkg]\n");
if *tc::value_restriction_top_warn
#
error_function source_code_region err::WARNING
"type vars not generalized because of\n\
\ value restriction are macro expanded to dummy types (X1, X2, ...)"
err::null_error_body;
fi;
fi;
if_debugging_say "\ngeneralize_type: returning [type-core-language-declaration-g.pkg]";
# Set the type variable we're generalizing
# to the type scheme we've constructed:
maybe_note_ref_in_undo_log (undo_log, vartypoid_ref);
vartypoid_ref := tdt::TYPESCHEME_TYPOID
{
typescheme
=>
tdt::TYPESCHEME { arity => *typescheme_arg_slots_allocated,
body => typescheme_body
},
typescheme_eqflags
=>
reverse *typescheme_eqflags
};
if_debugging_unparse_typoid ("\ngeneralize_type: final value for *vartypoid_ref (unparse): [type-core-language-declaration-g.pkg]", *vartypoid_ref);
if_debugging_prprint_typoid ("\ngeneralize_type: final value for *vartypoid_ref (prprint): [type-core-language-declaration-g.pkg]", *vartypoid_ref);
if *debugging
printf "\ngeneralize_type returning %d type variables: [type-core-language-declaration-g.pkg] \n" (list::length generalized_typevar_refs);
apply unparse_typevar_ref generalized_typevar_refs
where
/* */ fun unparse_typevar_ref typevar_ref
=
if_debugging_unparse_typevar_ref ("", typevar_ref);
end;
say ("\n^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n");
print_callstack "============= generalize_type/BOTTOM ==========" callstack;
say ( "\n");
fi;
generalized_typevar_refs; # Return generalized typevars.
};
generalize_type _ => bug "generalize_type - bad arg";
end; # fun generalize_type
# Make 'given_pattern' as typeagnostistic ("polymorphic")
# as possible by changing META_TYPEVAR and USER_TYPEVAR
# to tdt::TYPESCHEME_ARG wherever permitted
# by the "value restriction" as implemented
# by tyj::is_value() and passed to us
# via the 'generalize' parameter.
#
# The 'pattern' argument is updated by
# side effects; we return the list of
# generalized type variables.
#
# We are called from do_named_value()
# in do_declaration/VALUE_DECLARATIONS:
#
fun generalize_pattern # SIDE-EFFECT: SETS vac::PLAIN_VARIABLE.vartypoid_ref
(
given_pattern: ds::Case_Pattern, # Left-hand-side of a "fun foo ... = ..." or "my ... = ..." statement or such.
userbound: List( tdt::Typevar_Ref ), # List of type variables from 'given_pattern'.
syntax_treewalk_lexical_context: Syntax_Treewalk_Lexical_Context,
generalize: Bool,
source_code_region: ds::Source_Code_Region,
callstack: List(String) # Debug support.
)
: List( tdt::Typevar_Ref ) # These will actually always be tdt::META_TYPEVAR or tdt::USER_TYPEVAR
=
{
if *debugging print_callstack "\n============= generalize_pattern/TOP ============= " callstack; fi;
if_debugging_say "vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv [type-core-language-declaration-g.pkg]\n";
if *debugging
printf "lexical context: lex.fn_nesting d= %d outside_all_lets b= %s\n"
syntax_treewalk_lexical_context.fn_nesting (syntax_treewalk_lexical_context.outside_all_lets ?? "TRUE" :: "FALSE");
fi;
if_debugging_unparse_pattern ("\ndo_declaration/VALUE_DECLARATIONS/typecheck_named_value: pattern before generalization == [type-core-language-declaration-g.pkg]\n", (given_pattern,100));
generalized_typevars
=
REF( []: List( tdt::Typevar_Ref ) );
generalize_pattern' given_pattern
where
fun generalize_pattern' (ds::VARIABLE_IN_PATTERN variable)
=>
{ # This is the core case for this function;
# the others are just recursive descent
# to get here:
#
added_bound_typevar_refs
=
generalize_type # This is the only call to generalize_type(). SIDE-EFFECT: SETS vac::PLAIN_VARIABLE.vartypoid_ref
( variable,
userbound,
syntax_treewalk_lexical_context,
generalize,
source_code_region,
"generalize_pattern" ! callstack
);
if *debugging
/* */ fun unparse_typevar_ref typevar_ref
=
if_debugging_unparse_typevar_ref ("", typevar_ref);
say ("\ngeneralize_pattern' [type-core-language-declaration-g.pkg]: added_bound_typevar_refs: ");
apply unparse_typevar_ref added_bound_typevar_refs;
say ("\ngeneralize_pattern' [type-core-language-declaration-g.pkg]: *generalized_typevars: ");
apply unparse_typevar_ref *generalized_typevars;
fi;
case (added_bound_typevar_refs, *generalized_typevars)
#
(_ ! _, _ ! _) => bug "generalize_pattern' 1234"; # ???
_ => ();
esac;
generalized_typevars
:=
added_bound_typevar_refs
@
*generalized_typevars;
if *debugging
say ("\ngeneralize_pattern' [type-core-language-declaration-g.pkg]: resulting type variables list: ");
apply unparse_typevar_ref *generalized_typevars
where
/* */ fun unparse_typevar_ref typevar_ref
=
if_debugging_unparse_typevar_ref ("", typevar_ref);
end;
say ("\n");
fi;
};
generalize_pattern' (ds::RECORD_PATTERN { fields, ... } ) => apply (generalize_pattern' o #2) fields;
generalize_pattern' (ds::APPLY_PATTERN(_, _, arg) ) => generalize_pattern' arg;
generalize_pattern' (ds::TYPE_CONSTRAINT_PATTERN (pattern, _) ) => generalize_pattern' pattern;
generalize_pattern' (ds::AS_PATTERN (var_pattern, pattern)) => { generalize_pattern' var_pattern;
generalize_pattern' pattern;
};
generalize_pattern' _ => ();
end;
end;
if_debugging_unparse_pattern ("do_declaration/VALUE_DECLARATIONS/typecheck_named_value: pattern after generalization == [type-core-language-declaration-g.pkg]\n", (given_pattern,100));
if_debugging_say "\n^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^";
if *debugging print_callstack "\n============= generalize_pattern/BOTTOM ========== [type-core-language-declaration-g.pkg]" callstack; fi;
if_debugging_say "\n";
*generalized_typevars;
}; # fun generalize_pattern
# Compute type of f(x)
# given types for f and x:
#
fun compute_fn_application_type
( operator_type: tdt::Typoid,
operand_type: tdt::Typoid,
callstack: List(String)
): tdt::Typoid
=
{ result_type
=
tyj::make_meta_typevar_and_type
( tdt::infinity,
["compute_fn_application_type from type-core-language-declaration-g.pkg"]
);
if_debugging_say "\ncompute_fn_application_type calling unify_typoids [type-core-language-declaration-g.pkg]\n";
uyt::unify_typoids # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
(
"operator_type", "operand_type --> result_type",
operator_type, (operand_type --> result_type),
"compute_fn_application_type" ! callstack,
undo_log
);
if_debugging_say "\ncompute_fn_application_type back from unify_typoids [type-core-language-declaration-g.pkg]\n";
result_type;
};
# Use unification to compute the most
# general non-typeagnostic type for
# a pattern. This includes checking
# that all values in a vector pattern
# are of compatible type etc.
#
# Generalizing to typeagnostic type is
# done later if permitted by
# tyj::is_value():
#
fun compute_pattern_type # Not exported.
(
given_pattern: ds::Case_Pattern, # Compute a type for this pattern.
fn_nesting: Int, # Lexical nesting of fun/fn constructs at this point in deep syntax dagwalk.
source_code_region: ds::Source_Code_Region,
callstack: List(String) # Debug support.
)
:
( ds::Case_Pattern, # Possibly (probably) updated version of given_pattern deep syntax tree.
tdt::Typoid # Computed type of given_pattern.
)
=
{
if *debugging print_callstack "\ncompute_pattern_type/TOP [type-core-language-declaration-g.pkg]" callstack; fi;
if_debugging_unparse_pattern ("\ncompute_pattern_type/TOP [type-core-language-declaration-g.pkg] given_pattern == ", (given_pattern,100));
result
=
case given_pattern
#
ds::WILDCARD_PATTERN
=>
( given_pattern,
tyj::make_meta_typevar_and_type (fn_nesting, ["compute_pattern_type/WILDCARD_PATTERN from type-core-language-declaration-g.pkg"])
);
ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { vartypoid_ref as REF tdt::UNDEFINED_TYPOID, ... } )
=>
{
maybe_note_ref_in_undo_log (undo_log, vartypoid_ref);
vartypoid_ref := tyj::make_meta_typevar_and_type
( fn_nesting,
["compute_pattern_type/VARIABLE_IN_PATTERN from type-core-language-declaration-g.pkg"]
);
(given_pattern, *vartypoid_ref);
};
# Multiple occurrence due to or-pattern
#
ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { vartypoid_ref, ... } ) => (given_pattern, *vartypoid_ref);
ds::FLOAT_CONSTANT_IN_PATTERN _ => (given_pattern, mtt::float64_typoid);
ds::STRING_CONSTANT_IN_PATTERN _ => (given_pattern, mtt::string_typoid);
ds::CHAR_CONSTANT_IN_PATTERN _ => (given_pattern, mtt::char_typoid);
ds::INT_CONSTANT_IN_PATTERN (_, type) => { note_overloaded_literal type; (given_pattern, type); };
ds::UNT_CONSTANT_IN_PATTERN (_, type) => { note_overloaded_literal type; (given_pattern, type); };
ds::RECORD_PATTERN { fields, is_incomplete, type_ref }
=>
# The record fields are already sorted by label,
# typically by make_record_pattern() in
#
# src/lib/compiler/front/typer/main/typer-junk.pkg #
{ my (fields, field_types)
=
tyj::map_unzip do_field fields
where
fun do_field (label, pattern)
=
{ my (field_pattern, field_type)
=
compute_pattern_type
( pattern,
fn_nesting,
source_code_region,
"compute_pattern_type/RECORD_PATTERN" ! callstack
);
( (label, field_pattern),
(label, field_type)
);
};
end;
new_record_pattern
=
ds::RECORD_PATTERN { fields, is_incomplete, type_ref };
if (not is_incomplete)
#
( new_record_pattern,
mtt::record_typoid field_types
);
else
# We need to recover the rest of the fields
# in this record before we can compute a
# full type for it. In src/lib/compiler/front/typer-stuff/types/type-declaration-types.api # we define a special INCOMPLETE_RECORD_TYPEVAR
# just to handle this situation:
#
record_typoid
=
tdt::TYPEVAR_REF
(
tdt::make_typevar_ref
(
tyj::make_incomplete_record_typevar
(field_types, fn_nesting),
["compute_pattern_type/RECORD_PATTERN from type-core-language-declaration-g.pkg"]
) );
maybe_note_ref_in_undo_log (undo_log, type_ref);
type_ref := record_typoid;
(new_record_pattern, record_typoid);
fi;
};
ds::VECTOR_PATTERN (patterns, _)
=>
{
stipulate
fun do_pattern pattern
=
compute_pattern_type
( pattern,
fn_nesting,
source_code_region,
"compute_pattern_type/VECTOR_PATTERN" ! callstack
);
herein
(tyj::map_unzip do_pattern patterns)
->
(patterns, pattern_types);
end;
if_debugging_say "\ncompute_pattern_type/VECTOR_PATTERN folding calls to unify_typoids [type-core-language-declaration-g.pkg]\n";
# Force all vector elements
# to have the same type:
#
vector_element_type # SIDE-EFFECT: unify_typoids sets tdt::TYPEVAR_REF.ref_typevar
=
fold_backward
(\\ (a, b) = { uyt::unify_typoids ("vector a", "vector b", a, b, "compute_pattern_type/VECTOR_PATTERN(2)" ! callstack, undo_log); b;})
(tyj::make_meta_typevar_and_type (fn_nesting, "compute_pattern_type/VECTOR_PATTERN(3)" ! callstack))
pattern_types;
if_debugging_say "\ncompute_pattern_type/VECTOR_PATTERN done folding calls to unify_typoids [type-core-language-declaration-g.pkg]\n";
( ds::VECTOR_PATTERN (patterns, vector_element_type),
tdt::TYPCON_TYPOID (mtt::ro_vector_type, [ vector_element_type ] )
);
}
except
uyt::UNIFY_TYPOIDS mode
=
{ error_function
source_code_region
err::ERROR
(message("vector pattern type failure", mode))
err::null_error_body;
(given_pattern, tdt::WILDCARD_TYPOID);
};
ds::OR_PATTERN (pattern1, pattern2)
=>
{
if *debugging print_callstack "\ncompute_pattern_type/ds::OR_PATTERN/TOP [type-core-language-declaration-g.pkg]" callstack; fi;
my (pattern1, typoid1) = compute_pattern_type (pattern1, fn_nesting, source_code_region, "compute_pattern_type/ds::OR_PATTERN" ! callstack);
my (pattern2, typoid2) = compute_pattern_type (pattern2, fn_nesting, source_code_region, "compute_pattern_type/ds::OR_PATTERN(2)" ! callstack);
if_debugging_say "\ncompute_pattern_type/ds::OR_PATTERN calling unify_typoids_and_handle_errors [type-core-language-declaration-g.pkg]\n";
# Force both sides of the '|'
# pattern to have the same type:
#
unify_typoids_and_handle_errors # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
{
typoid1, name1 => "expected",
typoid2, name2 => "found",
message => "or-patterns don't agree",
source_code_region,
unparse_phrase => unparse_pattern,
phrase_name => "pattern",
phrase => given_pattern,
callstack => "compute_pattern_type/ds::OR_PATTERN(3)" ! callstack,
undo_log
};
if_debugging_say "\ncompute_pattern_type/ds::OR_PATTERN done calling unify_typoids_and_handle_errors [type-core-language-declaration-g.pkg]\n";
( ds::OR_PATTERN (pattern1, pattern2),
typoid1
);
};
ds::CONSTRUCTOR_PATTERN (valcon as tdt::VALCON { typoid, ... }, _)
=>
{ (tyj::instantiate_if_typescheme (typoid, symbolmapstack, "compute_pattern_type/ds::CONSTRUCTOR_PATTERN" ! callstack)) # symbolmapstack is used only for debugging.
->
(type, fresh_meta_typevars);
# The following is to set the correct fn_nesting information
# on the type variables in type. (ZHONG)
#
if_debugging_say "\ncompute_pattern_type/ds::CONSTRUCTOR_PATTERN calling unify_typoids [type-core-language-declaration-g.pkg]\n";
uyt::unify_typoids # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
(
"type", "temp_type",
type, temp_type,
["compute_pattern_type/ds::CONSTRUCTOR_PATTERN from type-core-language-declaration-g.pkg"],
undo_log
)
where
temp_type = tyj::make_meta_typevar_and_type
( fn_nesting,
["compute_pattern_type/ds::CONSTRUCTOR_PATTERN from type-core-language-declaration-g.pkg"]
);
end;
if_debugging_say "\ncompute_pattern_type/ds::CONSTRUCTOR_PATTERN done calling unify_typoids [type-core-language-declaration-g.pkg]\n";
( ds::CONSTRUCTOR_PATTERN (valcon, fresh_meta_typevars),
type
);
};
ds::APPLY_PATTERN (valcon as tdt::VALCON { typoid, form, ... }, _, arg)
=>
{ (compute_pattern_type ( arg,
fn_nesting,
source_code_region,
"compute_pattern_type/ds::APPLY_PATTERN" ! callstack
))
->
(arg_pattern, arg_type);
my (constructor, type)
=
case form varhome::REFCELL_REP => (ref_new_valcon valcon, mtt::ref_pattern_typoid);
_ => (valcon, typoid );
esac;
(tyj::instantiate_if_typescheme (type, symbolmapstack, "compute_pattern_type/ds::APPLY_PATTERN" ! callstack))
->
(type, fresh_meta_typevars);
result_pattern
=
ds::APPLY_PATTERN (constructor, fresh_meta_typevars, arg_pattern);
if_debugging_say "\ncompute_pattern_type/ds::APPLY_PATTERN calling compute_fn_application_type [type-core-language-declaration-g.pkg]\n";
( result_pattern,
compute_fn_application_type (type, arg_type, callstack)
)
except
uyt::UNIFY_TYPOIDS mode
=
{ error_function source_code_region err::ERROR
(message("constructor and argument don't agree in pattern", mode))
(\\ pp
=
{ uty::reset_unparse_type(); pp.newline();
pp.lit "constructor: ";
unparse_typoid pp type; pp.newline();
pp.lit "argument: ";
unparse_typoid pp arg_type; pp.newline();
pp.lit "in pattern:";
pp::break pp { blanks=>1, indent_on_wrap=>2 };
unparse_pattern pp (given_pattern, *print_depth);
}
);
( given_pattern,
tdt::WILDCARD_TYPOID
);
};
};
ds::TYPE_CONSTRAINT_PATTERN (pattern, type)
=>
{
if_debugging_say "\ncompute_pattern_type/ds::TYPE_CONSTRAINT_PATTERN calling compute_pattern_type [type-core-language-declaration-g.pkg]\n";
my (npat, pat_type)
=
compute_pattern_type
( pattern,
fn_nesting,
source_code_region,
"compute_pattern_type/ds::TYPE_CONSTRAINT_PATTERN" ! callstack
);
if_debugging_say "\ncompute_pattern_type/ds::TYPE_CONSTRAINT_PATTERN done calling compute_pattern_type [type-core-language-declaration-g.pkg]\n";
if_debugging_say "\ncompute_pattern_type/ds::TYPE_CONSTRAINT_PATTERN calling unify_typoids_and_handle_errors [type-core-language-declaration-g.pkg]\n";
if (unify_typoids_and_handle_errors # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
{
typoid1 => pat_type, name1 => "pattern",
typoid2 => type, name2 => "constraint",
message=>"pattern and constraint don't agree",
source_code_region,
unparse_phrase => unparse_pattern,
phrase_name => "pattern",
phrase => given_pattern,
callstack => "compute_pattern_type/ds::TYPE_CONSTRAINT_PATTERN(2)" ! callstack,
undo_log
}
)
if_debugging_say "\ncompute_pattern_type/ds::TYPE_CONSTRAINT_PATTERN done calling unify_typoids_and_handle_errors (succeeded) [type-core-language-declaration-g.pkg]\n";
( ds::TYPE_CONSTRAINT_PATTERN (npat, type),
type
);
else
if_debugging_say "\ncompute_pattern_type/ds::TYPE_CONSTRAINT_PATTERN done calling unify_typoids_and_handle_errors (failed) [type-core-language-declaration-g.pkg]\n";
( given_pattern,
tdt::WILDCARD_TYPOID
);
fi;
};
ds::AS_PATTERN (var_pattern as ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { vartypoid_ref, ... } ), main_pattern)
=>
{
if_debugging_say "\ncompute_pattern_type/AS_PATTERN calling compute_pattern_type [type-core-language-declaration-g.pkg]\n";
my (main_pattern, main_pattern_type)
=
compute_pattern_type
( main_pattern,
fn_nesting,
source_code_region,
"compute_pattern_type/AS_PATTERN" ! callstack
);
if_debugging_say "\ncompute_pattern_type/AS_PATTERN done calling compute_pattern_type [type-core-language-declaration-g.pkg]\n";
maybe_note_ref_in_undo_log (undo_log, vartypoid_ref);
vartypoid_ref := main_pattern_type;
( ds::AS_PATTERN (var_pattern, main_pattern),
main_pattern_type
);
};
ds::AS_PATTERN (constraint_pattern as ds::TYPE_CONSTRAINT_PATTERN (ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { vartypoid_ref, ... } ), constraining_type), main_pattern)
=>
{
if_debugging_say "\ncompute_pattern_type/AS_PATTERN II calling compute_pattern_type [type-core-language-declaration-g.pkg]\n";
my (main_pattern, main_pattern_type)
=
compute_pattern_type
( main_pattern,
fn_nesting,
source_code_region,
"compute_pattern_type/AS_PATTERN(2)" ! callstack
);
if_debugging_say "\ncompute_pattern_type/AS_PATTERN II done calling compute_pattern_type [type-core-language-declaration-g.pkg]\n";
if_debugging_say "\ncompute_pattern_type/AS_PATTERN II calling unify_typoids_and_handle_errors [type-core-language-declaration-g.pkg]\n";
if (unify_typoids_and_handle_errors # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
{
typoid1 => main_pattern_type, name1 => "pattern",
typoid2 => constraining_type, name2 => "constraint",
message => "pattern and constraint don't agree",
source_code_region,
unparse_phrase => unparse_pattern,
phrase_name => "pattern",
phrase => given_pattern,
callstack => "compute_pattern_type/AS_PATTERN(3)" ! callstack,
undo_log
}
)
if_debugging_say "\ncompute_pattern_type/AS_PATTERN II done calling unify_typoids_and_handle_errors (succeeded) [type-core-language-declaration-g.pkg]\n";
maybe_note_ref_in_undo_log (undo_log, vartypoid_ref);
vartypoid_ref := constraining_type;
( ds::AS_PATTERN (constraint_pattern, main_pattern),
constraining_type
);
else
if_debugging_say "\ncompute_pattern_type/AS_PATTERN II done calling unify_typoids_and_handle_errors (failed) [type-core-language-declaration-g.pkg]\n";
( given_pattern,
tdt::WILDCARD_TYPOID
);
fi;
};
p => bug "compute_pattern_type -- unexpected pattern";
esac; # fun compute_pattern_type
if *debugging print_callstack "\ncompute_pattern_type/BOTTOM [type-core-language-declaration-g.pkg] " callstack; fi;
result;
};
# Use unification to compute the most
# general non-typeagnostic type for
# an expression. This includes checking
# that all values in a vector are of
# compatible type etc.
#
# Generalizing to typeagnostic type
# is done later if permitted by
# is tyj::is_value():
#
fun compute_expression_type # Not exported.
(
given_expression: ds::Deep_Expression, # Our primary input. We do not modify it.
syntax_treewalk_lexical_context: Syntax_Treewalk_Lexical_Context,
source_code_region: ds::Source_Code_Region, # Debug support.
callstack: List(String) # Debug support.
)
:
(ds::Deep_Expression, tdt::Typoid) # Rewritten (fully typed) version of given_expression, plus its type.
=
{
if *debugging print_callstack "\ncompute_expression_type/TOP [type-core-language-declaration-g.pkg]" callstack; fi;
if_debugging_unparse_expression ("\ncompute_expression_type/TOP [type-core-language-declaration-g.pkg]: expression unparse == ", (given_expression,100));
if_debugging_prettyprint_expression ("\ncompute_expression_type/TOP [type-core-language-declaration-g.pkg]: expression prettyprint == ", (given_expression,100));
fun bool_unify_err { type, name, message }
=
{
if_debugging_say "\ncompute_expression_type: bool_unify_err: calling unify_and-handle_errors [type-core-language-declaration-g.pkg]\n";
result =
unify_typoids_and_handle_errors # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
{
typoid1 => type, name1 => name,
typoid2 => mtt::bool_typoid, name2 => "",
message,
source_code_region,
unparse_phrase => unparse_expression,
phrase_name => "expression",
phrase => given_expression,
callstack => "compute_expression_type()/bool_unify_error()" ! callstack,
undo_log
};
if_debugging_say "\ncompute_expression_type: bool_unify_err: done calling unify_and-handle_errors [type-core-language-declaration-g.pkg]\n";
result;
};
# Typing of boolean short-circuit
# operators 'and' and 'or':
#
fun short_circuit_and_or
(
con, # ds::AND_EXPRESSION or ds::OR_EXPRESSION
what, # "an" or "or"
expression1,
expression2
)
=
{ if_debugging_say "\ncompute_expression_type/short_circuit_and_or calling compute_expression_type. [type-core-language-declaration-g.pkg]";
my (expression1', type1) = compute_expression_type (expression1, syntax_treewalk_lexical_context, source_code_region, "compute_expression_type/short_circuit_and_or" ! callstack);
my (expression2', type2) = compute_expression_type (expression2, syntax_treewalk_lexical_context, source_code_region, "compute_expression_type/short_circuit_and_or(2)" ! callstack);
if_debugging_say "\ncompute_expression_type/short_circuit_and_or done calling compute_expression_type. [type-core-language-declaration-g.pkg]";
m = string::cat ["operand of ", what, " is not of type bool"];
if ( bool_unify_err { type => type1, name => "operand", message => m }
and bool_unify_err { type => type2, name => "operand", message => m }
)
( con (expression1', expression2'), #
mtt::bool_typoid
);
else
( given_expression, # Continue after error.
tdt::WILDCARD_TYPOID
);
fi;
};
if *debugging print_callstack "\ncompute_expression_type/TOP.z [type-core-language-declaration-g.pkg] " callstack; fi;
case given_expression
#
ds::VARIABLE_IN_EXPRESSION { var => var_ref as REF (vac::PLAIN_VARIABLE { vartypoid_ref, inlining_data, ... } ),
typescheme_args => _
}
=>
{
if_debugging_say "\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE/TOP. [type-core-language-declaration-g.pkg]";
if_debugging_unparse_typoid("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE unparse [type-core-language-declaration-g.pkg]: *vartypoid_ref == ", *vartypoid_ref);
if_debugging_prprint_typoid("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE prprint [type-core-language-declaration-g.pkg]: *vartypoid_ref == ", *vartypoid_ref);
case (inlining_data_to_my_type inlining_data) # For builtins like string::get_byte_as_char, inlining_data was set up from all_primops in src/lib/compiler/front/semantic/symbolmapstack/base-types-and-ops.pkg #
THE inl_typoid
=>
{ (tyj::instantiate_if_typescheme (inl_typoid, symbolmapstack, "compute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE/THE st" ! callstack)) -> (inl_typoid', fresh_meta_typevars);
(tyj::instantiate_if_typescheme (*vartypoid_ref, symbolmapstack, "compute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE/THE st" ! callstack)) -> (var_typoid', _);
/* */ fun prettyprint_typoid typoid = if_debugging_prprint_typoid ("", typoid);
len = list::length fresh_meta_typevars;
if_debugging_say "\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE/THE t. [type-core-language-declaration-g.pkg]";
if_debugging_unparse_typoid("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE/THE [type-core-language-declaration-g.pkg] unparse_typoid inl_typoid ==",inl_typoid);
if_debugging_prprint_typoid("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE/THE [type-core-language-declaration-g.pkg] prprint_typoid inl_typoid ==",inl_typoid);
if_debugging_unparse_typoid("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE/THE [type-core-language-declaration-g.pkg] unparse_typoid inl_typoid'==",inl_typoid');
if_debugging_prprint_typoid("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE/THE [type-core-language-declaration-g.pkg] prprint_typoid inl_typoid'==",inl_typoid');
if_debugging_unparse_typoid("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE/THE [type-core-language-declaration-g.pkg] unparse_typoid var_typoid'==",var_typoid');
if_debugging_prprint_typoid("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE/THE [type-core-language-declaration-g.pkg] prprint_typoid var_typoid'==",var_typoid');
if_debugging_say (sprintf "\nprprinting %d fresh_meta_typevars: compute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE [type-core-language-declaration-g.pkg]" len);
apply prettyprint_typoid fresh_meta_typevars;
if_debugging_say (sprintf "\nprprinted %d fresh_meta_typevars. compute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE [type-core-language-declaration-g.pkg]" len);
if_debugging_say "\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE II calling unify_typoids. [type-core-language-declaration-g.pkg]";
uyt::unify_typoids # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
( "inl_typoid'", "var_typoid'", inl_typoid', var_typoid',
["compute_expression_type/ds::VARIABLE_IN_EXPRESSION"],
undo_log
)
except
_ = (); # ??? XXX BUGGO FIXME
len = list::length fresh_meta_typevars;
if_debugging_say (sprintf "\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE II done calling unify_typoids%s. [type-core-language-declaration-g.pkg]"
(len > 0 ?? " -- NOW SETTING VARIABLE_IN_EXPRESSION.typescheme_args" :: ""));
if_debugging_say (sprintf "\nprprinting %d fresh_meta_typevars: compute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE.z [type-core-language-declaration-g.pkg]" len);
apply prettyprint_typoid fresh_meta_typevars;
if_debugging_say (sprintf "\nprprinted %d fresh_meta_typevars. compute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE.z [type-core-language-declaration-g.pkg]" len);
( ds::VARIABLE_IN_EXPRESSION
{ var => var_ref,
typescheme_args => fresh_meta_typevars
},
inl_typoid'
);
};
NULL =>
{
if_debugging_say "\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE I: calling tyj::instantiate_if_typescheme. [type-core-language-declaration-g.pkg]";
(tyj::instantiate_if_typescheme (*vartypoid_ref, symbolmapstack, "compute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE I" ! callstack))
->
(fresh_type, fresh_meta_typevars);
if_debugging_say "\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE I: done calling tyj::instantiate_if_typescheme. [type-core-language-declaration-g.pkg]";
if_debugging_unparse_typoid ("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE I: type unparse == [type-core-language-declaration-g.pkg]", fresh_type);
if_debugging_prprint_typoid ("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE I: type prprint == [type-core-language-declaration-g.pkg]", fresh_type);
if_debugging_unparse_expression ("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE I: result expression (unparse)== [type-core-language-declaration-g.pkg]",
(ds::VARIABLE_IN_EXPRESSION { var => var_ref, typescheme_args => fresh_meta_typevars },100));
if_debugging_prettyprint_expression ("\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::PLAIN_VARIABLE I: result expression (prprint) == [type-core-language-declaration-g.pkg]",
(ds::VARIABLE_IN_EXPRESSION { var => var_ref, typescheme_args => fresh_meta_typevars },100));
( ds::VARIABLE_IN_EXPRESSION
{ var => var_ref,
typescheme_args => fresh_meta_typevars
},
fresh_type
);
};
esac;
};
ds::VARIABLE_IN_EXPRESSION { var => var_ref as REF (vac::OVERLOADED_VARIABLE _), typescheme_args }
=>
{
if_debugging_say (sprintf "\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION/vac::OVERLOADED_VARIABLE. |typescheme_args|=%d [type-core-language-declaration-g.pkg] "
(list::length typescheme_args));
( given_expression,
note_overloaded_variable (var_ref, typescheme_args, error_function source_code_region)
);
};
ds::VARIABLE_IN_EXPRESSION { var => REF _, ... }
=>
{
if_debugging_say "\ncompute_expression_type/ds::VARIABLE_IN_EXPRESSION III. [type-core-language-declaration-g.pkg]";
( given_expression,
tdt::WILDCARD_TYPOID
);
};
ds::VALCON_IN_EXPRESSION { valcon as tdt::VALCON { typoid, ... }, ... }
=>
{
if_debugging_say "\ncompute_expression_type/VALCON_IN_EXPRESSION. [type-core-language-declaration-g.pkg]";
(tyj::instantiate_if_typescheme (typoid, symbolmapstack, "compute_expression_type/VALCON_IN_EXPRESSION" ! callstack))
->
(type, fresh_meta_typevars);
len = list::length fresh_meta_typevars;
if (len > 0)
if_debugging_say (sprintf "\ncompute_expression_type/ds::VALCON_IN_EXPRESSION -- NOW SETTING %d VALCON_IN_EXPRESSION.typescheme_args. [type-core-language-declaration-g.pkg]" len);
fi;
( ds::VALCON_IN_EXPRESSION { valcon, typescheme_args => fresh_meta_typevars },
type
);
};
ds::INT_CONSTANT_IN_EXPRESSION (_, type) => { note_overloaded_literal type; (given_expression, type);};
ds::UNT_CONSTANT_IN_EXPRESSION (_, type) => { note_overloaded_literal type; (given_expression, type);};
ds::FLOAT_CONSTANT_IN_EXPRESSION _ => (given_expression, mtt::float64_typoid);
ds::STRING_CONSTANT_IN_EXPRESSION _ => (given_expression, mtt::string_typoid);
ds::CHAR_CONSTANT_IN_EXPRESSION _ => (given_expression, mtt::char_typoid);
ds::RECORD_IN_EXPRESSION fields
=>
{ if_debugging_say "\ncompute_expression_type/RECORD_IN_EXPRESSION. [type-core-language-declaration-g.pkg]";
my (fields, field_types)
=
tyj::map_unzip do_field fields # Apply do_field to each field, return resulting value pairs in two lists.
where
fun do_field
( label as ds::NUMBERED_LABEL _,
expression'
)
=
{ my (expression, expression_type)
=
compute_expression_type
( expression',
syntax_treewalk_lexical_context,
source_code_region,
"compute_expression_type/RECORD_IN_EXPRESSION" ! callstack
);
( (label, expression),
(label, expression_type)
);
};
end;
record_typoid
=
map extract_field_name_and_type (tyj::sort_fields field_types)
where
fun extract_field_name_and_type (ds::NUMBERED_LABEL { name, ... }, field_type)
=
(name, field_type);
end;
( ds::RECORD_IN_EXPRESSION fields,
mtt::record_typoid record_typoid
);
};
ds::RECORD_SELECTOR_EXPRESSION (label, record_expression)
=>
{
if_debugging_say "\ncompute_expression_type/RECORD_SELECTOR_EXPRESSION [type-core-language-declaration-g.pkg]";
if_debugging_say "calling compute_expression_type: compute_expression_type/RECORD_SELECTOR_EXPRESSION [type-core-language-declaration-g.pkg]";
my (record_expression, record_expression_type)
=
compute_expression_type
( record_expression,
syntax_treewalk_lexical_context,
source_code_region,
"compute_expression_type/RECORD_SELECTOR_EXPRESSION" ! callstack
);
if_debugging_say "\ncompute_expression_type() call done: compute_expression_type/RECORD_SELECTOR_EXPRESSION [type-core-language-declaration-g.pkg]";
result_type
=
tyj::make_meta_typevar_and_type
( tdt::infinity,
["result_type in compute_expression_type/RECORD_SELECTOR_EXPRESSION from type-core-language-declaration-g.pkg"]
);
# Remember that we need to infer the
# the rest of the fields in the record:
#
incomplete_record_type
=
tdt::TYPEVAR_REF
(
tdt::make_typevar_ref
(
tyj::make_incomplete_record_typevar
(label_types, tdt::infinity),
["incomplete_record_type in compute_expression_type/RECORD_SELECTOR_EXPRESSION from type-core-language-declaration-g.pkg"]
) )
where
label_types = [ (typer_junk::symbol_naming_label label, result_type) ];
end;
{ if_debugging_say "\ncompute_expression_type/RECORD_SELECTOR_EXPRESSION: calling unify_typoids. [type-core-language-declaration-g.pkg]";
uyt::unify_typoids # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
( "incomplete_record_type", "record_expression_type",
incomplete_record_type, record_expression_type,
["compute_expression_type/RECORD_SELECTOR_EXPRESSION"],
undo_log
);
if_debugging_say "\ncompute_expression_type/RECORD_SELECTOR_EXPRESSION: done calling unify_typoids. [type-core-language-declaration-g.pkg]";
(ds::RECORD_SELECTOR_EXPRESSION (label, record_expression), result_type);
}
except
uyt::UNIFY_TYPOIDS mode
=
{ error_function
source_code_region
err::ERROR
( message("selecting a non-existing field from a record", mode))
(\\ pp
=
{ uty::reset_unparse_type ();
pp.newline();
pp.lit "the field name: ";
case label
ds::NUMBERED_LABEL { name, ... } => uj::unparse_symbol pp name;
esac;
pp.newline();
pp.lit "the record type: ";
unparse_typoid pp record_expression_type; pp.newline();
pp.lit "in expression:";
pp::break pp { blanks=>1, indent_on_wrap=>2 };
unparse_expression pp (given_expression, *print_depth);
}
);
( given_expression,
tdt::WILDCARD_TYPOID
);
};
};
ds::VECTOR_IN_EXPRESSION (expressions, _)
=>
{ if_debugging_say "\ncompute_expression_type/VECTOR_IN_EXPRESSION. [type-core-language-declaration-g.pkg]";
my (expressions, expression_types)
=
tyj::map_unzip
(\\ e = compute_expression_type ( e,
syntax_treewalk_lexical_context,
source_code_region,
"compute_expression_type/VECTOR_IN_EXPRESSION" ! callstack
)
)
expressions;
if_debugging_say "\ncompute_expression_type/VECTOR_IN_EXPRESSION: folding unify_typoids calls. [type-core-language-declaration-g.pkg]";
# Check that all expressions in vector have
# compatible types, and combine them all to
# yield the final vector element type:
#
vector_element_type
=
fold_backward
(\\ (a, b) = { uyt::unify_typoids( "vector a", # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
"vector b",
a, b,
["compute_expression_type/VECTOR_IN_EXPRESSION from type-core-language-declaration-g.pkg"],
undo_log
);
b;
}
)
(tyj::make_meta_typevar_and_type (tdt::infinity, ["compute_expression_type/VECTOR_IN_EXPRESSION from type-core-language-declaration-g.pkg"]))
expression_types;
if_debugging_say "\ncompute_expression_type/VECTOR_IN_EXPRESSION: done folding unify_typoids calls. [type-core-language-declaration-g.pkg]";
( ds::VECTOR_IN_EXPRESSION (expressions, vector_element_type),
tdt::TYPCON_TYPOID (mtt::ro_vector_type, [vector_element_type])
);
}
except
uyt::UNIFY_TYPOIDS mode
=
{ error_function source_code_region err::ERROR
(message("vector expression type failure", mode))
err::null_error_body;
(given_expression, tdt::WILDCARD_TYPOID);
};
ds::SEQUENTIAL_EXPRESSIONS expressions
=>
{ (scan expressions) -> (expressions, sequence_type);
#
( ds::SEQUENTIAL_EXPRESSIONS expressions,
sequence_type
);
}
where if_debugging_say "\ncompute_expression_type/SEQUENTIAL_EXPRESSION. [type-core-language-declaration-g.pkg]";
fun scan NIL
=>
(NIL, mtt::void_typoid);
scan [expression]
=>
{ my (expression, expression_type)
=
compute_expression_type
( expression,
syntax_treewalk_lexical_context,
source_code_region,
"compute_expression_type/SEQUENTIAL_EXPRESSIONS" ! callstack
);
([expression], expression_type);
};
scan (expression ! rest)
=>
{ # The type of a sequence of expressions is
# the type of the final expression. We
# do type-checking on all of them, but we
# only keep the result of last one:
my (expression, _) # Discard type of non-final expression.
=
compute_expression_type
( expression,
syntax_treewalk_lexical_context,
source_code_region,
"compute_expression_type/SEQUENTIAL_EXPRESSIONS(2)" ! callstack
);
(scan rest) -> (expressions, expression_type);
(expression ! expressions, expression_type); # Type of final expression is type of sequence.
};
end;
end;
ds::APPLY_EXPRESSION { operator, operand }
=>
{
if_debugging_say "\ncompute_expression_type/APPLY_EXPRESSION.1 [type-core-language-declaration-g.pkg]";
if_debugging_unparse_expression ("\ncompute_expression_type/APPLY_EXPRESSION.1 [type-core-language-declaration-g.pkg]: operator unparse == qqq ", (operator,100));
if_debugging_prettyprint_expression ("\ncompute_expression_type/APPLY_EXPRESSION.1 [type-core-language-declaration-g.pkg]: operator prprint == qqq ", (operator,100));
if_debugging_say "\ncompute_expression_type/APPLY_EXPRESSION.1 operator pprint done. [type-core-language-declaration-g.pkg]";
if_debugging_unparse_expression ("\ncompute_expression_type/APPLY_EXPRESSION.1 [type-core-language-declaration-g.pkg]: operand unparse == ", (operand, 100));
if_debugging_prettyprint_expression ("\ncompute_expression_type/APPLY_EXPRESSION.1 [type-core-language-declaration-g.pkg]: operand prprint == ", (operand, 100));
if_debugging_say "\ncompute_expression_type/APPLY_EXPRESSION.1: calling compute_expression_type on operator. [type-core-language-declaration-g.pkg]";
my (operator, operator_type)
=
compute_expression_type
(operator, syntax_treewalk_lexical_context, source_code_region, "compute_expression_type/APPLY_EXPRESSION" ! callstack);
if_debugging_say "\ncompute_expression_type/APPLY_EXPRESSION.2: done calling compute_expression_type on operator. [type-core-language-declaration-g.pkg]";
if_debugging_unparse_expression ("\ncompute_expression_type/APPLY_EXPRESSION.2 [type-core-language-declaration-g.pkg]: operator unparse == ", (operator,100));
if_debugging_prettyprint_expression ("\ncompute_expression_type/APPLY_EXPRESSION.2 [type-core-language-declaration-g.pkg]: operator prprint == ", (operator,100));
if_debugging_say "\ncompute_expression_type/APPLY_EXPRESSION.2 operator pprint done. [type-core-language-declaration-g.pkg]";
if_debugging_unparse_typoid ("\ncompute_expression_type/APPLY_EXPRESSION.2 [type-core-language-declaration-g.pkg]: operator_type unparse == ", operator_type);
if_debugging_prprint_typoid ("\ncompute_expression_type/APPLY_EXPRESSION.2 [type-core-language-declaration-g.pkg]: operator_type prprint == ", operator_type);
if_debugging_say "\ncompute_expression_type/APPLY_EXPRESSION [type-core-language-declaration-g.pkg]: calling compute_expression_type on operand.";
my (operand, operand_type)
=
compute_expression_type
( operand,
syntax_treewalk_lexical_context,
source_code_region,
"compute_expression_type/APPLY_EXPRESSION(2)" ! callstack
);
if_debugging_say "\ncompute_expression_type/APPLY_EXPRESSION.3 [type-core-language-declaration-g.pkg]: done calling compute_expression_type on operand.";
if_debugging_unparse_expression ("\ncompute_expression_type/APPLY_EXPRESSION.3 [type-core-language-declaration-g.pkg]: operand unparse == ", (operand,100));
if_debugging_prettyprint_expression ("\ncompute_expression_type/APPLY_EXPRESSION.3 [type-core-language-declaration-g.pkg]: operand prprint == ", (operand,100));
if_debugging_unparse_typoid ("\ncompute_expression_type/APPLY_EXPRESSION.3 [type-core-language-declaration-g.pkg]: operand_type unparse == ", operand_type);
if_debugging_prprint_typoid ("\ncompute_expression_type/APPLY_EXPRESSION.3 [type-core-language-declaration-g.pkg]: operand_type prprint == ", operand_type);
expression
=
ds::APPLY_EXPRESSION { operator, operand };
if_debugging_unparse_expression ("\ncompute_expression_type/APPLY_EXPRESSION [type-core-language-declaration-g.pkg]: expression == ", (expression,100));
{
if_debugging_say "\ncompute_expression_type/APPLY_EXPRESSION: calling compute_fn_application_type. [type-core-language-declaration-g.pkg]";
expression_type = compute_fn_application_type (operator_type, operand_type, callstack);
if_debugging_say "\ncompute_expression_type/APPLY_EXPRESSION: done calling compute_fn_application_type I. [type-core-language-declaration-g.pkg]";
if_debugging_prprint_typoid ("\ncompute_expression_type/APPLY_EXPRESSION.4 [type-core-language-declaration-g.pkg]: operator_type prprint == ", operator_type);
if_debugging_prprint_typoid ("\ncompute_expression_type/APPLY_EXPRESSION.4 [type-core-language-declaration-g.pkg]: operand_type prprint == ", operand_type);
if_debugging_prprint_typoid ("\ncompute_expression_type/APPLY_EXPRESSION.4 [type-core-language-declaration-g.pkg]: expression_type prprint == ", expression_type);
( expression,
expression_type
);
}
except
uyt::UNIFY_TYPOIDS mode
=
{
if_debugging_say "\ncompute_expression_type/APPLY_EXPRESSION: done calling compute_fn_application_type II. [type-core-language-declaration-g.pkg]";
operator_type = tyj::drop_resolved_typevars operator_type;
reduced_operator_type = tyj::head_reduce_typoid operator_type;
uty::reset_unparse_type ();
if (mtt::is_arrow_type (reduced_operator_type))
#
error_function source_code_region err::ERROR
(message("Operator and operand do not agree", mode))
(\\ pp
=
{
# pp.newline();
pp::break pp { blanks=>1, indent_on_wrap=>2 };
pp.box' 0 0 {.
pp.lit "operator domain: ";
unparse_typoid pp (mtt::domain reduced_operator_type);
};
pp::break pp { blanks=>1, indent_on_wrap=>2 };
# pp.newline();
pp.box' 0 0 {.
pp.lit "operand: ";
unparse_typoid pp operand_type;
};
pp::break pp { blanks=>1, indent_on_wrap=>2 };
# pp.newline();
pp.box' 0 0 {.
pp.lit "in expression:";
pp::break pp { blanks=>1, indent_on_wrap=>2 };
unparse_expression pp (given_expression, *print_depth);
};
pp::break pp { blanks=>1, indent_on_wrap=>2 };
}
);
(given_expression, tdt::WILDCARD_TYPOID);
else
error_function source_code_region err::ERROR
(message("operator is not a function", mode))
(\\ pp
=
{ pp.newline();
pp.lit "operator: ";
unparse_typoid pp (operator_type); pp.newline();
pp.lit "in expression:";
pp::break pp { blanks=>1, indent_on_wrap=>2 };
unparse_expression pp (given_expression,*print_depth);
}
);
(given_expression, tdt::WILDCARD_TYPOID);
fi;
};
};
ds::TYPE_CONSTRAINT_EXPRESSION (expression, constraining_type)
=>
{
if_debugging_say "\ncompute_expression_type/ds::TYPE_CONSTRAINT_EXPRESSION. [type-core-language-declaration-g.pkg]";
my (expression, expression_type)
=
compute_expression_type
( expression,
syntax_treewalk_lexical_context,
source_code_region,
"compute_expression_type/ds::TYPE_CONSTRAINT_EXPRESSION" ! callstack
);
if_debugging_say "\ncompute_expression_type/TYPE_CONSTRAINT_EXPRESSION: calling unify_typoids_and_handle_errors. [type-core-language-declaration-g.pkg]";
if (unify_typoids_and_handle_errors # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
{
typoid1 => expression_type, name1 => "expression",
typoid2 => constraining_type, name2 => "constraint",
message => "expression doesn't match constraint",
source_code_region,
unparse_phrase => unparse_expression,
phrase_name => "expression",
phrase => given_expression,
callstack => "compute_expression_type/ds::TYPE_CONSTRAINT_EXPRESSION(2)" ! callstack,
undo_log
}
)
if_debugging_say "\ncompute_expression_type/TYPE_CONSTRAINT_EXPRESSION: done calling unify_typoids_and_handle_errors (succeeded). [type-core-language-declaration-g.pkg]";
(ds::TYPE_CONSTRAINT_EXPRESSION (expression, constraining_type), constraining_type);
else
if_debugging_say "\ncompute_expression_type/TYPE_CONSTRAINT_EXPRESSION: done calling unify_typoids_and_handle_errors (failed). [type-core-language-declaration-g.pkg]";
(given_expression, tdt::WILDCARD_TYPOID);
fi;
};
ds::EXCEPT_EXPRESSION (expression, (rules, _))
=>
{
if_debugging_say "\ncompute_expression_type/EXCEPT_EXPRESSION. [type-core-language-declaration-g.pkg]";
my (expression, expression_type)
=
compute_expression_type
( expression,
syntax_treewalk_lexical_context,
source_code_region,
"compute_expression_type/EXCEPT_EXPRESSION" ! callstack
);
my (rules, rule_pattern_type, exception_handler_type)
=
compute_match_type
( rules,
syntax_treewalk_lexical_context,
source_code_region,
"compute_expression_type/EXCEPT_EXPRESSION(2)" ! callstack
);
expression = ds::EXCEPT_EXPRESSION (expression, (rules, rule_pattern_type));
if_debugging_say "\ncompute_expression_type/EXCEPT_EXPRESSION: above call to unify_typoids [type-core-language-declaration-g.pkg]";
{ uyt::unify_typoids # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
( "exception_handler_type", "exception_typoid --> expression_type",
exception_handler_type, mtt::exception_typoid --> expression_type,
["compute_expression_type/EXCEPT_EXPRESSION"],
undo_log
);
(expression, expression_type);
}
except uyt::UNIFY_TYPOIDS mode
=
{
if_debugging_say "\ncompute_expression_type/EXCEPT_EXPRESSION: above second call to unify_typoids [type-core-language-declaration-g.pkg]";
if (unify_typoids_and_handle_errors # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
{
typoid1 => mtt::domain (tyj::drop_resolved_typevars exception_handler_type), name1 => "handler domain",
typoid2 => mtt::exception_typoid, name2 => "",
message => "handler domain is not exception",
source_code_region,
unparse_phrase => unparse_expression,
phrase_name => "expression",
phrase => given_expression,
callstack => "compute_expression_type/EXCEPT_EXPRESSION(3)" ! callstack,
undo_log
}
)
if_debugging_say "\ncompute_expression_type/EXCEPT_EXPRESSION: above third call to unify_typoids [type-core-language-declaration-g.pkg]";
unify_typoids_and_handle_errors # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
{
typoid1 => expression_type, name1 => "body",
typoid2 => mtt::range (tyj::drop_resolved_typevars exception_handler_type), name2 => "handler range",
message => "expression and handler don't agree",
source_code_region,
unparse_phrase => unparse_expression,
phrase_name => "expression",
phrase => given_expression,
callstack => "compute_expression_type/EXCEPT_EXPRESSION(4)" ! callstack,
undo_log
};
else
FALSE;
fi;
( given_expression,
tdt::WILDCARD_TYPOID
);
};
};
ds::RAISE_EXPRESSION (expression, _)
=>
{
if_debugging_say "\ncompute_expression_type/RAISE_EXPRESSION: TOP: calling compute_expression_type. [type-core-language-declaration-g.pkg]";
my (expression, expression_type)
=
compute_expression_type
( expression,
syntax_treewalk_lexical_context,
source_code_region,
"compute_expression_type/RAISE_EXPRESSION" ! callstack
);
if_debugging_say "\ncompute_expression_type/RAISE_EXPRESSION: BBB: back from compute_expression_type. [type-core-language-declaration-g.pkg]";
if_debugging_say "\ncompute_expression_type/RAISE_EXPRESSION: CCC: calling unify_typoids_and_handle_errors. [type-core-language-declaration-g.pkg]";
# Verify that 'expression' has an exception type:
#
unify_typoids_and_handle_errors # SIDE-EFFECT: Sets tdt::TYPEVAR_REF.ref_typevar
{
typoid1 => expression_type, name1 => "raised",
typoid2 => mtt::exception_typoid, name2 => "",
message => "argument of raise is not an exception",
source_code_region,
unparse_phrase => unparse_expression,
phrase_name => "expression",
phrase => given_expression,
callstack => "compute_expression_type/RAISE_EXPRESSION(2)" ! callstack,
&