## type-core-language.pkg
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib# The epicenter of the typechecker is
#
# src/lib/compiler/front/typer/main/type-package-language-g.pkg#
# -- see it for a higher-level overview.
# It calls us to typecheck core-language syntax,
# which is to say, bread-and-butter function and
# declaration code devoid of module-level stuff
# like packages, apis and generics.
# NOMENCLATURE:
# Throughout this file:
# 'src' == "source_code_region"
stipulate
package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package lnd = line_number_db; # line_number_db is from src/lib/compiler/front/basics/source/line-number-db.pkg package raw = raw_syntax; # raw_syntax is from src/lib/compiler/front/parser/raw-syntax/raw-syntax.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package trj = typer_junk; # typer_junk is from src/lib/compiler/front/typer/main/typer-junk.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkgherein
api Type_Core_Language {
#
type_declaration: ( raw::Declaration,
syx::Symbolmapstack,
(tdt::Type -> Bool),
ip::Inverse_Path,
lnd::Source_Code_Region,
trj::Per_Compile_Stuff
)
->
( ds::Declaration,
syx::Symbolmapstack
);
debugging: Ref( Bool );
}; # api Type_Core_Language
end;
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 fst = find_in_symbolmapstack; # find_in_symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/find-in-symbolmapstack.pkg package id = inlining_data; # inlining_data is from src/lib/compiler/front/typer-stuff/basics/inlining-data.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package mj = module_junk; # module_junk is from src/lib/compiler/front/typer-stuff/modules/module-junk.pkg package mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.pkg package raw = raw_syntax; # raw_syntax is from src/lib/compiler/front/parser/raw-syntax/raw-syntax.pkg package sht = symbol_hashtable; # symbol_hashtable is from src/lib/compiler/front/basics/hash/symbol-hashtable.pkg package sxe = symbolmapstack_entry; # symbolmapstack_entry is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack-entry.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package syp = symbol_path; # symbol_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package trd = typer_debugging; # typer_debugging is from src/lib/compiler/front/typer/main/typer-debugging.pkg package trj = typer_junk; # typer_junk is from src/lib/compiler/front/typer/main/typer-junk.pkg package tro = typerstore; # typerstore is from src/lib/compiler/front/typer-stuff/modules/typerstore.pkg package tj = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package tt = type_type; # type_type is from src/lib/compiler/front/typer/main/type-type.pkg package tvs = typevar_set; # typevar_set is from src/lib/compiler/front/typer/main/type-variable-set.pkg package uds = unparse_deep_syntax; # unparse_deep_syntax is from src/lib/compiler/front/typer/print/unparse-deep-syntax.pkg package vac = variables_and_constructors; # variables_and_constructors is from src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg #
# rewrite_raw_syntax_expression is from src/lib/compiler/front/typer/main/rewrite-raw-syntax-expression.pkg rewrite_raw_syntax_expression
=
rewrite_raw_syntax_expression::rewrite_raw_syntax_expression;
herein
# This package is used (only) in:
#
# src/lib/compiler/front/typer/main/type-package-language-g.pkg #
package type_core_language
: (weak) Type_Core_Language # Type_Core_Language is from src/lib/compiler/front/typer/main/type-core-language.pkg {
fun c_markexp (e, r) = if *typer_control::mark_deep_syntax_tree ds::SOURCE_CODE_REGION_FOR_EXPRESSION (e, r); else e;fi;
fun c_markdec (d, r) = if *typer_control::mark_deep_syntax_tree ds::SOURCE_CODE_REGION_FOR_DECLARATION (d, r); else d;fi;
say = control_print::say;
debugging = REF FALSE;
#
fun if_debugging_say (msg: String)
=
if *debugging
say msg;
say "\n";
fi;
#
fun bug msg
=
error_message::impossible("type_core_language: " + msg);
debug_print = \\ x = trd::debug_print debugging x;
#
fun show_declaration (msg, declaration, symbolmapstack)
=
# trd::with_internals (\\ () =>
debug_print ( msg,
(\\ pps = \\ declaration = uds::unparse_declaration (symbolmapstack, NULL) pps (declaration, 100)),
declaration
);
# )
infix my --> ;
Typevar_Set_Update # Typevar_Set management.
=
tvs::Typevar_Set -> Void;
my ---- = tvs::diff_pure;
union = tvs::union;
diff = tvs::diff;
#
fun no_update (_ : tvs::Typevar_Set)
=
();
#
fun no_typevars (declaration, symbolmapstack)
=
(declaration, symbolmapstack, tvs::empty, no_update);
infix my +++ --- ---- ;
#
fun strip_exp_abs (ds::SOURCE_CODE_REGION_FOR_EXPRESSION (e, _)) => strip_exp_abs e;
strip_exp_abs (ds::TYPE_CONSTRAINT_EXPRESSION (e, _)) => strip_exp_abs e;
strip_exp_abs e => e;
end;
#
fun strip_exp_raw_syntax_tree (raw::SOURCE_CODE_REGION_FOR_EXPRESSION (e, r'), r) => strip_exp_raw_syntax_tree (e, r');
strip_exp_raw_syntax_tree (raw::TYPE_CONSTRAINT_EXPRESSION { expression=>e, ... }, r) => strip_exp_raw_syntax_tree (e, r);
strip_exp_raw_syntax_tree (raw::SEQUENCE_EXPRESSION [e], r) => strip_exp_raw_syntax_tree (e, r);
strip_exp_raw_syntax_tree (raw::PRE_FIXITY_EXPRESSION [{ item, source_code_region, ... } ], r) => strip_exp_raw_syntax_tree (item, source_code_region);
strip_exp_raw_syntax_tree x => x;
end;
internal_sym = special_symbols::internal_var_id;
dummy_fnexp
=
ds::FN_EXPRESSION ( [ ds::CASE_RULE ( ds::WILDCARD_PATTERN,
ds::RAISE_EXPRESSION (ds::VALCON_IN_EXPRESSION { valcon => vac::bogus_exception, typescheme_args => [] }, tdt::UNDEFINED_TYPOID)
)
],
tdt::UNDEFINED_TYPOID
);
# LAZY
# clauseKind: used for communicating information about lazy fun decls
# between preprocessing phase (makeVar) and main part of typecheckSMLFUNdec
Clause_Kind = STRICT | LAZY_OUTER | LAZY_INNER;
stipulate
fun make_core_expression name symbolmapstack
=
ds::VARIABLE_IN_EXPRESSION { var => REF (core_access::get_variable (symbolmapstack, name)), typescheme_args => [] };
herein
make_assignment_expression = make_core_expression "assign";
make_dereference_expression = make_core_expression "deref";
end;
# Typecheck core-language (non-module) declarations.
#
# This function contains about 95% of the code in this file. :)
#
# The most interesting case here, which involves most of
# the coding, is a sequence of mutually recursive functions
# like
#
# fun foo this => expression1;
# foo that => expression2;
# end
#
# also
# fun bar this => expression3;
# bar that => expression4;
# end;
#
# where (say) 'this' may in turn be something as complicated as
#
# a as SOME_CONSTRUCTOR { key1 = value1, key2 = ANOTHER_CONSTRUCTOR (b, _, c) }
#
# and of course each of the 'expression's can be a block
# full of if-then-else-fi statements and loops and so forth.
#
# Processing any set of mutually recursive entities
# is normally a two-phase process, with a first phase
# which locates all the entities and a second phase
# which processes them, and this is no exception:
#
# We process such a declaration in two phases,
# analysis followed by synthesis:
#
# Analysis Phase:
# Do sanity checks that all definitions of a
# given function use the same name for it
# (say, "foo") and have the same number of
# arguments and so forth.
#
# In this phase we also boil down the raw
# syntax tree somewhat, allot symbols
# as function names, and set up symbol
# table entries for functions. (These are
# mostly place-holders at this point since
# we have not yet constructed the actual
# corresponding symbol table values.)
#
# Synthesis Phase:
# Do the actual translation from raw syntax
# to deep syntax.
#
# Complete the symbol table definitions
# set up in Analysis Phase.
#
# This function gets invoked from exactly one place,
# in type_declaration'() in src/lib/compiler/front/typer/main/type-package-language-g.pkg #
fun type_declaration ( declaration,
symbolmapstack,
is_free,
inverse_path,
src,
per_compile_stuff as { issue_highcode_codetemp,
error_fn,
error_match,
...
}
)
=
{
if_debugging_say ">>type_core_language::type_declaration";
complete_match = trj::complete_match (symbolmapstack, "MATCH");
if_debugging_say "--type_core_language::type_declaration << completeBind Match";
complete_bind = trj::complete_match (symbolmapstack, "BIND");
if_debugging_say "--type_core_language::type_declaration << completeBind BIND";
# Create a symbol table entry for a
# vanilla variable. Input is a
# value-space symbol::symbol, result
# is a variables_and_constructors::variable::PLAIN_VARIABLE:
#
fun new_valvar symbol
=
vac::make_ordinary_variable ( symbol,
vh::named_varhome (symbol, issue_highcode_codetemp)
);
# LAZY: utilities for lazy sml translation
# Will one forcingFun do, or should new ones be generated with
# different bound variables for each use? (David B MacQueen) XXX QUERO FIXME
#
fun force_expression e
=
{ v = new_valvar (sy::make_value_symbol "x");
#
ds::APPLY_EXPRESSION {
operator =>
ds::FN_EXPRESSION (
complete_match [
ds::CASE_RULE (
ds::APPLY_PATTERN (
mtt::dollar_valcon,
[],
ds::VARIABLE_IN_PATTERN v
),
ds::VARIABLE_IN_EXPRESSION { var => REF v, typescheme_args => [] }
)
],
tdt::UNDEFINED_TYPOID
),
operand => e
};
# David B MacQueen: second arg of APPLY_PATTERN and VARIABLE_IN_EXPRESSION = NIL and
# of FN_EXPRESSION = tdt::UNDEFINED_TYPOID ok? XXX QUERO FIXME
};
#
fun delay_expression e
=
ds::APPLY_EXPRESSION {
operator => ds::VALCON_IN_EXPRESSION { valcon => mtt::dollar_valcon, typescheme_args => [] },
operand => e
};
# Build declaration of n-ary Y combinator for lazy my rec
#
fun lazy_rec_val_make_ycombinator_declaration n
=
{ fun upto 0 => [];
upto n => n ! (upto (n - 1));
end;
base = reverse (upto n); # [1, 2, ..., n]
#
fun repeat f
=
map f base;
#
fun hold e
=
delay_expression (force_expression e);
# Capture MATCH exception from coreDict as
# a random exception for use internally
# in the Y combinator definition:
#
exn = core_access::get_exception (symbolmapstack, "MATCH"); # "exn" == "exception"
# exn = vac::bogusException; /* See if this will work? */
# Y variable and local variables ri and fi and d
yvar = new_valvar( sy::make_value_symbol( "Y@@@" + (int::to_string n))); # As PLAIN_VARIABLE { path, type, varhome, info }
#
fun make_var_sym s i
=
new_valvar( sy::make_value_symbol( s + (int::to_string i)));
rvars = repeat (make_var_sym "r@@@");
fvars = repeat (make_var_sym "f@@@");
dvar = new_valvar (sy::make_value_symbol "d@@@");
# "REF(@@@(raise exception MATCH))"
#
fun rdr_expression _
=
ds::APPLY_EXPRESSION {
operator => ds::VALCON_IN_EXPRESSION { valcon => mtt::ref_valcon, typescheme_args => [] },
operand => delay_expression (ds::RAISE_EXPRESSION (ds::VALCON_IN_EXPRESSION { valcon => exn, typescheme_args => [] }, tdt::UNDEFINED_TYPOID))
};
rpat = trj::tuplepat (map ds::VARIABLE_IN_PATTERN rvars);
int_expression = trj::tupleexp (repeat rdr_expression);
rdec = ds::VALUE_DECLARATIONS
(
[ ds::VALUE_NAMING { pattern => rpat,
expression => int_expression,
generalized_typevars => [],
raw_typevars => REF []
}
]
);
# "@@@(force *ri)"
#
fun dfbr rv
=
hold (
ds::APPLY_EXPRESSION {
operator => make_dereference_expression symbolmapstack,
operand => ds::VARIABLE_IN_EXPRESSION { var => REF rv, typescheme_args => [] }
}
);
ddec = ds::VALUE_DECLARATIONS
[
ds::VALUE_NAMING { pattern => ds::VARIABLE_IN_PATTERN dvar,
expression => trj::tupleexp (map dfbr rvars),
generalized_typevars => [],
raw_typevars => REF []
}
];
#
fun dexp ()
=
ds::VARIABLE_IN_EXPRESSION { var => REF dvar, typescheme_args => [] };
#
fun setr_expression (rv, fv)
=
ds::APPLY_EXPRESSION {
operator => make_assignment_expression symbolmapstack,
operand => trj::tupleexp (
[ ds::VARIABLE_IN_EXPRESSION { var => REF rv, typescheme_args => [] },
hold (
ds::APPLY_EXPRESSION {
operator => ds::VARIABLE_IN_EXPRESSION { var => REF fv, typescheme_args => [] },
operand => dexp ()
}
)
]
)
};
updates = paired_lists::map setr_expression (rvars, fvars);
yexp = ds::FN_EXPRESSION (
complete_match
[ ds::CASE_RULE
(
trj::tuplepat (map ds::VARIABLE_IN_PATTERN fvars),
ds::LET_EXPRESSION
(
ds::SEQUENTIAL_DECLARATIONS [rdec, ddec],
ds::SEQUENTIAL_EXPRESSIONS (updates @ [ dexp() ] )
)
)
],
tdt::UNDEFINED_TYPOID
);
( yvar,
#
ds::VALUE_DECLARATIONS [
#
ds::VALUE_NAMING
{
pattern => ds::VARIABLE_IN_PATTERN yvar,
expression => yexp,
generalized_typevars => [],
raw_typevars => REF []
}
]
);
}; # fun lazyRecValMakeYCombinatorDeclaration
# *** EXCEPTION DECLARATIONS ***
#
fun type_named_exception (src: ds::Source_Code_Region)
(symbolmapstack: syx::Symbolmapstack)
(named_exception: raw::Named_Exception)
=
case named_exception
#
raw::NAMED_EXCEPTION { exception_symbol=>id, exception_type=>NULL }
=>
{ exn = tdt::VALCON { name => id,
is_constant => TRUE,
typoid => mtt::exception_typoid,
#
is_lazy => FALSE,
form => vh::EXCEPTION ( vh::HIGHCODE_VARIABLE ( issue_highcode_codetemp (THE id))),
signature => vh::NULLARY_CONSTRUCTOR
};
( [ ds::NAMED_EXCEPTION { exception_constructor => exn,
exception_typoid => NULL,
name_string => ds::STRING_CONSTANT_IN_EXPRESSION (sy::name id)
}
],
syx::bind ( id,
sxe::NAMED_CONSTRUCTOR exn,
syx::empty
),
tvs::empty
);
};
raw::NAMED_EXCEPTION { exception_symbol => id,
exception_type => THE type
}
=>
{ (tt::type_type (type, symbolmapstack, error_fn, src))
->
(type, vt);
(-->) = mtt::(-->);
exn = tdt::VALCON { name => id,
is_constant => FALSE,
typoid => (type --> mtt::exception_typoid),
#
is_lazy => FALSE,
form => vh::EXCEPTION (vh::HIGHCODE_VARIABLE (issue_highcode_codetemp (THE id))),
signature => vh::NULLARY_CONSTRUCTOR
};
( [ ds::NAMED_EXCEPTION { exception_constructor => exn,
exception_typoid => THE type,
name_string => ds::STRING_CONSTANT_IN_EXPRESSION (sy::name id)
}
],
syx::bind ( id,
sxe::NAMED_CONSTRUCTOR exn,
syx::empty
),
vt
);
};
raw::DUPLICATE_NAMED_EXCEPTION { exception_symbol=>id, equal_to=>qid }
=>
{ (fst::find_exception_via_symbol_path (symbolmapstack, syp::SYMBOL_PATH qid, error_fn src))
->
(equal_to as tdt::VALCON { is_constant, typoid, signature, ... });
new_form = vh::EXCEPTION( vh::HIGHCODE_VARIABLE( issue_highcode_codetemp (THE id)));
exn = tdt::VALCON { name => id,
is_lazy => FALSE,
form => new_form,
is_constant,
typoid,
signature
};
( [ ds::DUPLICATE_NAMED_EXCEPTION { exception_constructor=>exn, equal_to } ],
syx::bind (id, sxe::NAMED_CONSTRUCTOR exn, syx::empty),
tvs::empty
);
};
raw::SOURCE_CODE_REGION_FOR_NAMED_EXCEPTION (named_exception, src)
=>
type_named_exception src symbolmapstack named_exception;
esac;
#
fun type_exceptiondec ( excbinds: List( raw::Named_Exception ),
symbolmapstack: syx::Symbolmapstack,
src
)
=
{ my (named_exceptions, symbolmapstack, vt)
=
fold_forward
(\\ (exc1, (named_exceptions1, symbolmapstack1, vt1))
=
{ (type_named_exception src symbolmapstack exc1)
->
(named_exception2, symbolmapstack2, vt2);
( named_exception2 @ named_exceptions1,
syx::atop (symbolmapstack2, symbolmapstack1),
union (vt1, vt2, error_fn src)
);
}
)
([], syx::empty, tvs::empty)
excbinds;
#
fun get_name (ds::NAMED_EXCEPTION { exception_constructor => tdt::VALCON { name, ... }, ... } ) => name;
get_name (ds::DUPLICATE_NAMED_EXCEPTION { exception_constructor => tdt::VALCON { name, ... }, ... } ) => name;
end;
trj::forbid_duplicates_in_list
( error_fn src,
"duplicate exception declaration",
map get_name named_exceptions
);
( ds::EXCEPTION_DECLARATIONS (reverse named_exceptions),
symbolmapstack,
vt,
no_update
);
};
# *** PATTERNS ***
#
fun apply_pattern
( constructor as raw::SOURCE_CODE_REGION_FOR_PATTERN ( _, (l1, r1)),
argument as raw::SOURCE_CODE_REGION_FOR_PATTERN ( _, (l2, r2))
)
=>
raw::SOURCE_CODE_REGION_FOR_PATTERN
(
raw::APPLY_PATTERN { constructor, argument },
( int::min (l1, l2),
int::max (r1, r2)
)
);
apply_pattern (constructor, argument)
=>
raw::APPLY_PATTERN { constructor, argument };
end;
#
fun tuple_pattern
( a as raw::SOURCE_CODE_REGION_FOR_PATTERN (_, (l, _)),
b as raw::SOURCE_CODE_REGION_FOR_PATTERN (_, (_, r))
)
=>
raw::SOURCE_CODE_REGION_FOR_PATTERN (raw::TUPLE_PATTERN [a, b], (l, r));
tuple_pattern (a, b)
=>
raw::TUPLE_PATTERN [a, b];
end;
exception FREE_OR_VARIABLES;
# resolve_operator_precedence is from src/lib/compiler/front/typer/main/resolve-operator-precedence.pkg # The Mythryl parser doesn't resolve infix
# expressions because the user-specified
# infix precedences etc aren't known at that
# point.
#
# Instead, the parser passes them through
# and we resolve the package in a post-pass.
#
# Here we build the post-pass
# precedence resolver for patterns.
# (Later we build a matching one for expressions.)
#
# 'resolve_pattern_by_fixity' gets invoked in exactly
# one place, the RAW::PRE_FIXITY_PATTERN
# case within 'type_pattern', the
# immediately following function. XXX BUGGO FIXME put it in a local...in...end
#
resolve_pattern_by_fixity
=
resolve_operator_precedence::parse
{ apply => apply_pattern,
pair => tuple_pattern
};
# Translate a raw-syntax pattern
# to a deep-syntax one, typechecking,
# syntax-checking and sanity-checking
# as we go.
#
# If the statement being compiled was
#
# fun foo a b c = expression
#
# then at this point 'pattern' will be
# bound to one of syntax trees a b c --
# which might be some complicated
#
# c as { bar = ..., zot = ZOT(...) }
#
# syntax tree.
#
# This is mostly just a matter of grinding
# through all the cases -- a raw variable
# becomes a deep variable, a raw integer
# constant becomes a deep integer constant
# etc etc etc.
#
# One nontrivial operation:
# Any constructor applications (which
# may be prefix or infix) are at this
# point held in an undigested
# RAW::PRE_FIXITY_PATTERN patterns
#
fun type_pattern (
pattern: raw::Case_Pattern,
symbolmapstack: syx::Symbolmapstack,
src: ds::Source_Code_Region
)
:
( ds::Case_Pattern,
tvs::Typevar_Set
)
=
{ case pattern
#
raw::WILDCARD_PATTERN
=>
(ds::WILDCARD_PATTERN, tvs::empty);
raw::VARIABLE_IN_PATTERN path
=>
( trj::clean_pattern
(error_fn src)
(trj::do_var_pattern (syp::SYMBOL_PATH path, symbolmapstack, error_fn src, per_compile_stuff)),
tvs::empty
);
raw::INT_CONSTANT_IN_PATTERN s
=>
(ds::INT_CONSTANT_IN_PATTERN (s, tj::make_overloaded_literal_typevar (tdt::INT, src, ["type_pattern/INT_CONSTANT_IN_PATTERN from type-core-language.pkg"])), tvs::empty);
raw::UNT_CONSTANT_IN_PATTERN s
=>
(ds::UNT_CONSTANT_IN_PATTERN (s, tj::make_overloaded_literal_typevar (tdt::UNT, src, ["type_pattern/UNT_CONSTANT_IN_PATTERN from type-core-language.pkg"])), tvs::empty);
raw::STRING_CONSTANT_IN_PATTERN s
=>
(ds::STRING_CONSTANT_IN_PATTERN s, tvs::empty);
raw::CHAR_CONSTANT_IN_PATTERN s
=>
(ds::CHAR_CONSTANT_IN_PATTERN s, tvs::empty);
raw::RECORD_PATTERN { definition, is_incomplete }
=>
{ (type_labelled_patterns src symbolmapstack definition)
->
(lps, tyv);
( trj::make_record_pattern (lps, is_incomplete, error_fn src),
tyv
);
};
raw::LIST_PATTERN NIL
=>
(trj::nilpat, tvs::empty);
raw::LIST_PATTERN (a ! rest)
=>
{ (type_pattern (raw::TUPLE_PATTERN [a, raw::LIST_PATTERN rest], symbolmapstack, src))
->
(p, tyv);
(trj::conspat p, tyv);
};
raw::TUPLE_PATTERN pats
=>
{ (type_pattern_list (pats, symbolmapstack, src))
->
(ps, tyv);
(trj::tuplepat ps, tyv);
};
raw::VECTOR_PATTERN pats
=>
{ (type_pattern_list (pats, symbolmapstack, src))
->
(ps, tyv);
( ds::VECTOR_PATTERN (ps, tdt::UNDEFINED_TYPOID),
tyv
);
};
raw::APPLY_PATTERN { constructor, argument }
=>
type_constructor (constructor, src)
where
fun type_constructor (raw::SOURCE_CODE_REGION_FOR_PATTERN (pattern, src), src')
=>
type_constructor (pattern, src);
type_constructor (raw::VARIABLE_IN_PATTERN path, src')
=>
{ dcb = trj::do_var_pattern (syp::SYMBOL_PATH path, symbolmapstack, error_fn src', per_compile_stuff);
#
(type_pattern (argument, symbolmapstack, src))
->
(pattern, typevar);
( trj::make_apply_pattern (error_fn src) (dcb, pattern),
typevar
);
};
type_constructor (_, src')
=>
{ error_fn
src'
err::ERROR
"non-constructor applied to argument in pattern"
err::null_error_body;
(ds::WILDCARD_PATTERN, tvs::empty);
};
end;
end;
raw::TYPE_CONSTRAINT_PATTERN { pattern, type_constraint => type }
=>
{ (type_pattern (pattern, symbolmapstack, src)) -> (p1, typevar1);
(tt::type_type (type, symbolmapstack, error_fn, src)) -> (t2, typevar2);
( ds::TYPE_CONSTRAINT_PATTERN (p1, t2),
#
union (typevar1, typevar2, error_fn src)
);
};
raw::AS_PATTERN { variable_pattern, expression_pattern }
=>
{ my (p1, typevar1) = type_pattern ( variable_pattern, symbolmapstack, src);
my (p2, typevar2) = type_pattern (expression_pattern, symbolmapstack, src);
( trj::make_layered_pattern (p1, p2, error_fn src),
#
union (typevar1, typevar2, error_fn src)
);
};
raw::SOURCE_CODE_REGION_FOR_PATTERN (pattern, src)
=>
type_pattern (pattern, symbolmapstack, src);
raw::PRE_FIXITY_PATTERN patterns
=>
# Here is one of the few nontrivial
# cases in this routine.
#
# Recall that Mythryl allows user-declared
# precedence and fixity for functions
# and constructors.
#
# Since those declarations haven't been
# resolved yet at parse time, the Mythryl
# parser passes through constructor
# patterns as undigested RAW::PRE_FIXITY_PATTERN
# nodes, which must later be resolved
# via resolve_operator_precedence::parse
# once all precedence and fixity info is in hand.
#
# We're now at that 'later' point, so here
# we do the full parsetree resolution, then
# call ourselves recursively to process the
# now fully-defined pattern parsetree:
#
type_pattern (
resolve_pattern_by_fixity (patterns, symbolmapstack, error_fn),
symbolmapstack,
src
);
raw::OR_PATTERN pats
=>
# Check that the sub-patterns of an
# or-pattern have exactly the same
# free variables.
#
# Also, rewrite the sub-patterns so that
# all instances of a given free variable
# have the same type REF and the same
# varhome:
{ (type_pattern_list (pats, symbolmapstack, src))
->
(ps, tyv);
#
fun free_or_vars (pattern ! pats)
=>
{ table = sht::make_hashtable { size_hint => 16, not_found_exception => FREE_OR_VARIABLES }
: sht::Hashtable( (vh::Varhome, Ref( tdt::Typoid ), Int) );
#
fun ins kv
=
sht::set table kv;
#
fun get k
=
sht::get table k;
#
fun error_msg x
=
error_fn
src
err::ERROR
( "variable "
+ sy::name x
+ " does not occur in all branches of or-pattern"
)
err::null_error_body;
#
fun ins_fn (id, varhome, type)
=
{ ins (id, (varhome, type, 1));
#
(varhome, type);
};
#
fun bump_fn (id, varhome0, a_type0)
=
{ (get id) -> (varhome, type, n);
#
ins (id, (varhome, type, n+1));
(varhome, type);
}
except
FREE_OR_VARIABLES
=
{ error_msg id;
(varhome0, a_type0);
};
#
fun check_fn (id, varhome0, a_type0)
=
{ (get id) -> (varhome, type, _);
#
(varhome, type);
}
except
FREE_OR_VARIABLES
=
{ error_msg id;
(varhome0, a_type0);
};
#
fun do_pattern ( ins_fn: (sy::Symbol, vh::Varhome, Ref(tdt::Typoid))
->
(vh::Varhome, Ref( tdt::Typoid ))
)
=
{ fun do_pattern' (
ds::VARIABLE_IN_PATTERN (
vac::PLAIN_VARIABLE { varhome, inlining_data, path, vartypoid_ref }
)
)
=>
{ (ins_fn (symbol_path::first path, varhome, vartypoid_ref))
->
(varhome, vartypoid_ref);
ds::VARIABLE_IN_PATTERN (
vac::PLAIN_VARIABLE { vartypoid_ref,
varhome,
path,
inlining_data
}
);
};
do_pattern' (ds::RECORD_PATTERN { fields, is_incomplete, type_ref } )
=>
ds::RECORD_PATTERN
{
fields => map (\\ (l, p) = (l, do_pattern' p)) fields,
is_incomplete,
type_ref
};
do_pattern' (ds::APPLY_PATTERN (dc, type, pattern))
=>
ds::APPLY_PATTERN (dc, type, do_pattern' pattern);
do_pattern' (ds::TYPE_CONSTRAINT_PATTERN (pattern, type))
=>
ds::TYPE_CONSTRAINT_PATTERN (do_pattern' pattern, type);
do_pattern' (ds::AS_PATTERN (p1, p2))
=>
ds::AS_PATTERN (do_pattern' p1, do_pattern' p2);
do_pattern' (ds::OR_PATTERN (p1, p2))
=>
ds::OR_PATTERN (do_pattern' p1, do_pattern check_fn p2);
do_pattern' (ds::VECTOR_PATTERN (pats, type))
=>
ds::VECTOR_PATTERN (map do_pattern' pats, type);
do_pattern' pattern
=>
pattern;
end;
do_pattern';
};
# Check that each variable occurs in each sub-pattern:
#
fun check_complete m (id, (_, _, n: Int))
=
if (n != m) error_msg id; fi;
pats = (do_pattern ins_fn pattern)
!
(map (do_pattern bump_fn) pats);
sht::keyed_apply (check_complete (length pats)) table;
pats;
}; # freeOrVars
free_or_vars _
=>
bug "freeOrVars";
end;
my (pattern, pats)
=
case (free_or_vars ps)
#
(h ! t) => (h, t);
_ => bug "type_pattern: no free or vars";
esac;
#
fun fold_or (p, [] ) => p;
fold_or (p, p' ! r) => ds::OR_PATTERN (p, fold_or (p', r));
end;
( fold_or (pattern, pats),
tyv
);
};
esac;
} # end of type_pattern
# Translate a record pattern
# from raw syntax to deep syntax,
# typechecking, syntax-checking
# and sanity-checking as we go.
#
# If the input source code was something like
#
# fun foo { lab1 = pat1, lab2 = pat2 ... } = expression;
#
# then at this point our 'labelledPatterns' argument
# is the list of "lab=pat" clauses from inside the
# curly braces.
#
# All we really have to do here is pick apart the
# list, apply type_pattern to the patterns,
# and assemble the list of results -- type_pattern
# does all the heavy lifting for us:
also
fun type_labelled_patterns (src: ds::Source_Code_Region) (symbolmapstack: syx::Symbolmapstack) labelled_patterns
=
fold_forward
(\\ ((label1, pattern1), (labelled_patterns1, typevar_set1))
=
{ (type_pattern (pattern1, symbolmapstack, src))
->
(pattern2, typevar_set2);
( (label1, pattern2) ! labelled_patterns1,
union (typevar_set2, typevar_set1, error_fn src)
);
}
)
([], tvs::empty)
labelled_patterns
# Translate a list of patterns
# from raw syntax to deep syntax,
# typechecking, syntax-checking
# and sanity-checking as we go.
#
# If the input statement was
#
# fun foo a b c = expression
#
# then "patterns" will be a list of
# three(?) (simple!) pattern syntax trees.
also
fun type_pattern_list (patterns, symbolmapstack: syx::Symbolmapstack, src: ds::Source_Code_Region)
=
fold_backward
(\\ (p1, (lps1, lvt1))
=
{ (type_pattern (p1, symbolmapstack, src))
->
(p2, lvt2);
(p2 ! lps1, union (lvt2, lvt1, error_fn src));
}
)
([], tvs::empty)
patterns;
# INFIX EXPRESSION RESOLUTION
#
# The Mythryl parser proper does not resolve
# infix expressions because the user-specified
# infix precedences and associativities are not
# known at that point.
#
# Instead, the parser passes infix expressions
# through as unresolved symbol sequences and we
# recover the actual tree structure of these
# expressions in a post-pass.
#
# Here we build the post-pass
# precedence resolver for expressions.
# (Previously we built one for patterns.)
#
# 'resolve_expression_by_fixity' gets invoked
# in exactly one place, the RAW::PRE_FIXITY_EXPRESSION
# case within 'type_expression', the
# immediately following function.
#
resolve_expression_by_fixity
= # resolve_operator_precedence is from src/lib/compiler/front/typer/main/resolve-operator-precedence.pkg resolve_operator_precedence::parse
{
pair => \\ (a, b) = raw::TUPLE_EXPRESSION [a, b],
#
apply => \\ (function, argument)
=
raw::APPLY_EXPRESSION { function, argument }
};
#
fun type_expression ( expression: raw::Raw_Expression,
symbolmapstack: syx::Symbolmapstack,
src: ds::Source_Code_Region
)
:
( ds::Deep_Expression,
tvs::Typevar_Set,
Typevar_Set_Update
)
=
case expression
#
raw::VARIABLE_IN_EXPRESSION path
=>
(value, tvs::empty, no_update)
where
value = case (fst::find_value_via_symbol_path (symbolmapstack, syp::SYMBOL_PATH path, error_fn src))
#
vac::VARIABLE v
=>
ds::VARIABLE_IN_EXPRESSION { var => REF v, typescheme_args => [] };
vac::CONSTRUCTOR (d as tdt::VALCON { is_lazy, is_constant, ... } )
=>
if is_lazy
# # LAZY
if is_constant
#
delay_expression (ds::VALCON_IN_EXPRESSION { valcon => d, typescheme_args => [] });
else
var = new_valvar (sy::make_value_symbol "x");
ds::FN_EXPRESSION (
complete_match
[ ds::CASE_RULE (
ds::VARIABLE_IN_PATTERN var,
delay_expression (
ds::APPLY_EXPRESSION {
operator => ds::VALCON_IN_EXPRESSION { valcon => d, typescheme_args => [] },
operand => ds::VARIABLE_IN_EXPRESSION { var => REF var, typescheme_args => [] }
}
)
)
],
tdt::UNDEFINED_TYPOID # David B MacQueen: ?
);
fi;
else
ds::VALCON_IN_EXPRESSION { valcon => d, typescheme_args => [] };
fi;
esac;
end;
raw::IMPLICIT_THUNK_PARAMETER path
=>
{ # We use IMPLICIT_THUNK_PARAMETER to represent #x
# variables early in parsing. They are all supposed
# to get converted to VARIABLE_IN_EXPRESSION long
# before we get here, so if we see one here, it is a bug:
#
exception IMPOSSIBLE;
raise exception IMPOSSIBLE; # XXX BUGGO FIXME should be using some standard exception here.
};
raw::INT_CONSTANT_IN_EXPRESSION s
=>
( ds::INT_CONSTANT_IN_EXPRESSION (s, tj::make_overloaded_literal_typevar (tdt::INT, src, ["type_expression/INT_CONSTANT_IN_EXPRESSION from type-core-language.pkg"])),
tvs::empty,
no_update
);
raw::UNT_CONSTANT_IN_EXPRESSION s
=>
( ds::UNT_CONSTANT_IN_EXPRESSION (s, tj::make_overloaded_literal_typevar (tdt::UNT, src, ["type_expression/UNT_CONSTANT_IN_EXPRESSION from type-core-language.pkg"])),
tvs::empty,
no_update
);
raw::FLOAT_CONSTANT_IN_EXPRESSION r
=>
( ds::FLOAT_CONSTANT_IN_EXPRESSION r,
tvs::empty,
no_update
);
raw::STRING_CONSTANT_IN_EXPRESSION s
=>
( ds::STRING_CONSTANT_IN_EXPRESSION s,
tvs::empty,
no_update
);
raw::CHAR_CONSTANT_IN_EXPRESSION s
=>
( ds::CHAR_CONSTANT_IN_EXPRESSION s,
tvs::empty,
no_update
);
raw::RECORD_IN_EXPRESSION cells
=>
{ (type_record_element_expressions (cells, symbolmapstack, src))
->
(les, tyv, update);
( trj::make_record_expression (les, error_fn src),
tyv,
update
);
};
raw::SEQUENCE_EXPRESSION exps
=>
case exps
#
[e] => type_expression (e, symbolmapstack, src);
[] => bug "type_expression (SEQUENCE_EXPRESSION[])";
_ => { (type_expression_list (exps, symbolmapstack, src))
->
(es, tyv, update);
( ds::SEQUENTIAL_EXPRESSIONS es,
tyv,
update
);
};
esac;
raw::LIST_EXPRESSION NIL
=>
( trj::nilexp,
tvs::empty,
no_update
);
raw::LIST_EXPRESSION (a ! rest)
=>
{ my (e, tyv, update)
=
type_expression (
raw::TUPLE_EXPRESSION [ a, raw::LIST_EXPRESSION rest],
symbolmapstack,
src
);
( ds::APPLY_EXPRESSION { operator => trj::consexp, operand => e },
tyv,
update
);
};
raw::TUPLE_EXPRESSION exps
=>
{ (type_expression_list (exps, symbolmapstack, src))
->
(es, tyv, update);
( trj::tupleexp es,
tyv,
update
);
};
raw::VECTOR_IN_EXPRESSION exps
=>
{ (type_expression_list (exps, symbolmapstack, src))
->
(es, tyv, update);
( ds::VECTOR_IN_EXPRESSION (es, tdt::UNDEFINED_TYPOID),
tyv,
update
);
};
raw::APPLY_EXPRESSION { function, argument }
=>
{ (type_expression (function, symbolmapstack, src)) -> (e1, typevar1, finalize_deep_syntax_typevar_sets_fn1);
(type_expression (argument, symbolmapstack, src)) -> (e2, typevar2, finalize_deep_syntax_typevar_sets_fn2);
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ finalize_deep_syntax_typevar_sets_fn1 typevar_set;
finalize_deep_syntax_typevar_sets_fn2 typevar_set;
};
( ds::APPLY_EXPRESSION { operator => e1, operand => e2 },
union (typevar1, typevar2, error_fn src),
finalize_deep_syntax_typevar_sets_fn
);
};
raw::OBJECT_FIELD_EXPRESSION { object, field }
=>
{
error_fn
src
err::ERROR
"object->field not allowed outside of class definition"
err::null_error_body;
# Return random valid value:
#
( ds::STRING_CONSTANT_IN_EXPRESSION "",
tvs::empty,
no_update
);
};
raw::TYPE_CONSTRAINT_EXPRESSION { expression, constraint => type }
=>
{ (type_expression (expression, symbolmapstack, src))
->
(e1, typevar1, update);
(tt::type_type (type, symbolmapstack, error_fn, src))
->
(t2, typevar2);
( ds::TYPE_CONSTRAINT_EXPRESSION (e1, t2),
union (typevar1, typevar2, error_fn src),
update
);
};
raw::EXCEPT_EXPRESSION { expression, rules }
=>
{ (type_expression (expression, symbolmapstack, src)) -> (e1, typevar1, finalize_deep_syntax_typevar_sets_fn1);
(type_case_rules (rules, symbolmapstack, src)) -> (rls2, typevar2, finalize_deep_syntax_typevar_sets_fn2);
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ finalize_deep_syntax_typevar_sets_fn1 typevar_set;
finalize_deep_syntax_typevar_sets_fn2 typevar_set;
};
( trj::make_handle_expression (e1, rls2, per_compile_stuff),
union (typevar1, typevar2, error_fn src),
finalize_deep_syntax_typevar_sets_fn
);
};
raw::RAISE_EXPRESSION expression
=>
{ (type_expression (expression, symbolmapstack, src))
->
(e, tyv, update);
( ds::RAISE_EXPRESSION (e, tdt::UNDEFINED_TYPOID),
tyv,
update
);
};
raw::LET_EXPRESSION { declaration, expression }
=>
{ (type_declaration' (declaration, symbolmapstack, ip::INVERSE_PATH [], src)) -> (d1, e1, typevar1, finalize_deep_syntax_typevar_sets_fn1);
(type_expression (expression, syx::atop (e1, symbolmapstack), src)) -> ( e2, typevar2, finalize_deep_syntax_typevar_sets_fn2);
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ finalize_deep_syntax_typevar_sets_fn1 typevar_set;
finalize_deep_syntax_typevar_sets_fn2 typevar_set;
};
( ds::LET_EXPRESSION (d1, e2),
union (typevar1, typevar2, error_fn src),
finalize_deep_syntax_typevar_sets_fn
);
};
raw::CASE_EXPRESSION { expression, rules }
=>
{ (type_expression (expression, symbolmapstack, src)) -> (e1, typevar1, finalize_deep_syntax_typevar_sets_fn1);
(type_case_rules (rules, symbolmapstack, src)) -> (rls2, typevar2, finalize_deep_syntax_typevar_sets_fn2);
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ finalize_deep_syntax_typevar_sets_fn1 typevar_set;
finalize_deep_syntax_typevar_sets_fn2 typevar_set;
};
( ds::CASE_EXPRESSION (e1, complete_match rls2, TRUE),
union (typevar1, typevar2, error_fn src),
finalize_deep_syntax_typevar_sets_fn
);
};
raw::IF_EXPRESSION { test_case, then_case, else_case }
=>
{ (type_expression (test_case, symbolmapstack, src)) -> (e1, typevar1, finalize_deep_syntax_typevar_sets_fn1);
(type_expression (then_case, symbolmapstack, src)) -> (e2, typevar2, finalize_deep_syntax_typevar_sets_fn2);
(type_expression (else_case, symbolmapstack, src)) -> (e3, typevar3, finalize_deep_syntax_typevar_sets_fn3);
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ finalize_deep_syntax_typevar_sets_fn1 typevar_set;
finalize_deep_syntax_typevar_sets_fn2 typevar_set;
finalize_deep_syntax_typevar_sets_fn3 typevar_set;
};
( ds::IF_EXPRESSION { test_case => e1, then_case => e2, else_case => e3 },
union (typevar1, union (typevar2, typevar3, error_fn src), error_fn src),
finalize_deep_syntax_typevar_sets_fn
);
};
raw::AND_EXPRESSION (expression1, expression2)
=>
{ (type_expression (expression1, symbolmapstack, src)) -> (e1, typevar1, finalize_deep_syntax_typevar_sets_fn1);
(type_expression (expression2, symbolmapstack, src)) -> (e2, typevar2, finalize_deep_syntax_typevar_sets_fn2);
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ finalize_deep_syntax_typevar_sets_fn1 typevar_set;
finalize_deep_syntax_typevar_sets_fn2 typevar_set;
};
( ds::AND_EXPRESSION (e1, e2),
union (typevar1, typevar2, error_fn src),
finalize_deep_syntax_typevar_sets_fn
);
};
raw::OR_EXPRESSION (expression1, expression2)
=>
{ (type_expression (expression1, symbolmapstack, src)) -> (e1, typevar1, finalize_deep_syntax_typevar_sets_fn1);
(type_expression (expression2, symbolmapstack, src)) -> (e2, typevar2, finalize_deep_syntax_typevar_sets_fn2);
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ finalize_deep_syntax_typevar_sets_fn1 typevar_set;
finalize_deep_syntax_typevar_sets_fn2 typevar_set;
};
( ds::OR_EXPRESSION (e1, e2),
union (typevar1, typevar2, error_fn src),
finalize_deep_syntax_typevar_sets_fn
);
};
raw::WHILE_EXPRESSION { test, expression }
=>
{ (type_expression (test, symbolmapstack, src)) -> (e1, typevar1, finalize_deep_syntax_typevar_sets_fn1);
(type_expression (expression, symbolmapstack, src)) -> (e2, typevar2, finalize_deep_syntax_typevar_sets_fn2);
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ finalize_deep_syntax_typevar_sets_fn1 typevar_set;
finalize_deep_syntax_typevar_sets_fn2 typevar_set;
};
( ds::WHILE_EXPRESSION { test => e1, expression => e2 },
union (typevar1, typevar2, error_fn src),
finalize_deep_syntax_typevar_sets_fn
);
};
raw::FN_EXPRESSION rules
=>
{ (type_case_rules (rules, symbolmapstack, src))
->
(rls, tyv, update);
( ds::FN_EXPRESSION (complete_match rls, tdt::UNDEFINED_TYPOID),
tyv,
update
);
};
raw::SOURCE_CODE_REGION_FOR_EXPRESSION (expression, src)
=>
{ (type_expression (expression, symbolmapstack, src))
->
(e, tyv, update);
( c_markexp (e, src),
tyv,
update
);
};
raw::RECORD_SELECTOR_EXPRESSION s
=>
( { v = new_valvar s;
#
ds::FN_EXPRESSION (
#
complete_match
[ ds::CASE_RULE (
#
ds::RECORD_PATTERN
{
fields => [ (s, ds::VARIABLE_IN_PATTERN v)],
is_incomplete => TRUE,
type_ref => REF tdt::UNDEFINED_TYPOID
},
c_markexp (
ds::VARIABLE_IN_EXPRESSION { var => REF v, typescheme_args => [] },
src
)
)
],
tdt::UNDEFINED_TYPOID
);
},
tvs::empty,
no_update
);
raw::PRE_FIXITY_EXPRESSION items
=>
# Here is one of the few nontrivial
# cases in this routine.
#
# Recall that Mythryl allows user-declared
# precedence and fixity for functions
# and constructors. (E.g., 'infix my 60 ** ;'.)
#
# Since those declarations haven't been
# resolved yet at parse time, the Mythryl
# parser passes through function and constructor
# expressions as undigested RAW::PRE_FIXITY_EXPRESSION
# nodes, which must later be resolved
# via resolve_operator_precedence::parse from
# src/lib/compiler/front/typer/main/resolve-operator-precedence.pkg # once all precedence and fixity info is in hand.
#
# We're now at that 'later' point, so here
# we do the full parsetree resolution, then
# call ourselves recursively to process the
# now fully-defined expression parsetree:
#
type_expression (
rewrite_raw_syntax_expression (resolve_expression_by_fixity (items, symbolmapstack, error_fn)),
symbolmapstack,
src
);
esac # fun type_expression
also
fun type_record_element_expressions (labels, symbolmapstack, src)
=
{ my (les1, lvt1, finalize_deep_syntax_typevar_sets_fns)
=
fold_backward
( \\ ((lb2, e2), (les2, lvt2, updates2))
=
{ (type_expression (e2, symbolmapstack, src))
->
(e3, lvt3, update3);
( (lb2, e3) ! les2,
union (lvt3, lvt2, error_fn src),
update3 ! updates2
);
}
)
([], tvs::empty, [])
labels;
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
apply
(\\ f = f typevar_set)
finalize_deep_syntax_typevar_sets_fns;
(les1, lvt1, finalize_deep_syntax_typevar_sets_fn);
}
also
fun type_expression_list (es, symbolmapstack, src)
=
{ my (les1, lvt1, finalize_deep_syntax_typevar_sets_fns)
=
fold_backward
( \\ (e2, (es2, lvt2, updates2))
=
{ (type_expression (e2, symbolmapstack, src))
->
(e3, lvt3, update3);
( e3 ! es2,
union (lvt3, lvt2, error_fn src),
update3 ! updates2
);
}
)
([], tvs::empty, [])
es;
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
apply
(\\ f = f typevar_set)
finalize_deep_syntax_typevar_sets_fns;
(les1, lvt1, finalize_deep_syntax_typevar_sets_fn);
}
also
fun type_case_rules (rule_patterns, symbolmapstack, src)
=
# 'rule_patterns' is the
# list of 'pattern => expression"
# rules constituting some 'case'
# statement or 'fun' def.
#
{ my (rules, lvt, update1)
=
fold_backward
(\\ (r1, (rules1, lvt1, update1))
=
{ (type_case_rule (r1, symbolmapstack, src))
->
(r2, lvt2, update2);
( r2 ! rules1,
union (lvt2, lvt1, error_fn src),
update2 ! update1
);
}
)
([], tvs::empty, [])
rule_patterns;
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
apply (\\ f = f typevar_set) update1;
(rules, lvt, finalize_deep_syntax_typevar_sets_fn);
}
where
fun type_case_rule (raw::CASE_RULE { pattern, expression }, symbolmapstack, src)
=
# We're given one "pattern => expression"
# rule from a case statement or fun def:
# translate it from raw syntax into deep syntax.
#
{ src' = case pattern
#
raw::SOURCE_CODE_REGION_FOR_PATTERN (p, reg) => reg;
_ => src;
esac;
(type_pattern (pattern, symbolmapstack, src))
->
(p, typevar1);
symbolmapstack' = syx::atop (trj::bind_varp ([p], error_fn src'), symbolmapstack);
(type_expression (expression, symbolmapstack', src))
->
(e, typevar2, update);
( ds::CASE_RULE (p, e),
union (typevar1, typevar2, error_fn src),
update
);
};
end
# Simple declarations:
#
also
fun type_declaration' (declaration, symbolmapstack, inverse_path, src)
:
( ds::Declaration,
syx::Symbolmapstack,
tvs::Typevar_Set,
Typevar_Set_Update
)
=
case declaration
#
raw::TYPE_DECLARATIONS named_types
=>
{ my (declaration', symbolmapstack')
=
tt::type_type_declaration (
named_types,
symbolmapstack, # trj::TOP,??? XXX BUGGO FIXME
inverse_path,
src,
per_compile_stuff
);
no_typevars (declaration', symbolmapstack');
};
raw::SUMTYPE_DECLARATIONS (x as { sumtypes, with_types } )
=>
( case sumtypes
#
(raw::SUM_TYPE { right_hand_side => (raw::VALCONS _), ... }) ! _
=>
{ my (dtypes, wtypes, _, symbolmapstack')
=
tt::type_sumtype_declaration (
x,
symbolmapstack,
[],
tro::empty,
is_free,
inverse_path,
src,
per_compile_stuff
);
no_typevars (
ds::SUMTYPE_DECLARATIONS { sumtypes => dtypes,
with_types => wtypes
},
symbolmapstack'
);
};
(raw::SUM_TYPE {
name_symbol,
right_hand_side => raw::REPLICAS symbols,
typevars => NIL,
is_lazy => FALSE
}
!
NIL
)
=>
# LAZY: not allowing "lazy This = That'"
# BUG: what to do if rhs is lazy sumtype? (David B MacQueen)
#
case with_types
#
NIL =>
{ type = fst::find_type_via_symbol_path
( symbolmapstack,
syp::SYMBOL_PATH symbols,
error_fn src
);
dcons = tj::extract_sumtype type;
env_dcons
=
fold_forward
(\\ (d as tdt::VALCON { name, ... }, e)
=
syx::bind (name, sxe::NAMED_CONSTRUCTOR d, e)
)
syx::empty
dcons;
symbolmapstack
=
syx::bind (
name_symbol,
sxe::NAMED_TYPE type,
env_dcons
);
no_typevars (
ds::SUMTYPE_DECLARATIONS { sumtypes => [type],
with_types => []
},
symbolmapstack
);
};
_ => { error_fn
src
err::ERROR
"withtype not allowed in sumtype replication"
err::null_error_body;
no_typevars (ds::SEQUENTIAL_DECLARATIONS [], syx::empty);
};
esac;
_ => { error_fn
src
err::ERROR
"argument type variables in sumtype replication"
err::null_error_body;
no_typevars (ds::SEQUENTIAL_DECLARATIONS [], syx::empty);
};
esac
);
raw::EXCEPTION_DECLARATIONS named_exceptions
=>
type_exceptiondec (named_exceptions, symbolmapstack, src);
raw::VALUE_DECLARATIONS (vbs, explicit_typevar_refs)
=>
type_valdec (vbs, explicit_typevar_refs, symbolmapstack, inverse_path, src);
raw::FIELD_DECLARATIONS (fields, explicit_typevar_refs)
=>
type_fielddec (fields, explicit_typevar_refs, symbolmapstack, inverse_path, src);
raw::FUNCTION_DECLARATIONS (named_functions, explicit_typevar_refs)
=>
type_smlfundec (named_functions, explicit_typevar_refs, symbolmapstack, inverse_path, src);
raw::NADA_FUNCTION_DECLARATIONS (named_functions, explicit_typevar_refs)
=>
type_lib7fundec (named_functions, explicit_typevar_refs, symbolmapstack, inverse_path, src);
raw::RECURSIVE_VALUE_DECLARATIONS (rvbs, explicit_typevar_refs)
=>
type_valrecdec (rvbs, explicit_typevar_refs, symbolmapstack, inverse_path, src);
raw::SEQUENTIAL_DECLARATIONS ds
=>
type_seqdec (ds, symbolmapstack, inverse_path, src);
raw::LOCAL_DECLARATIONS ld
=>
type_localdec (ld, symbolmapstack, inverse_path, src);
raw::INCLUDE_DECLARATIONS ds
=>
type_include_declarations (ds, symbolmapstack, src);
raw::FIXITY_DECLARATIONS (ds as { fixity, ops } )
=>
{ symbolmapstack
=
fold_backward
( \\ (id, symbolmapstack)
=
syx::bind (id, sxe::NAMED_FIXITY fixity, symbolmapstack)
)
syx::empty ops;
( ds::FIXITY_DECLARATION ds,
symbolmapstack,
tvs::empty,
no_update
);
};
raw::OVERLOADED_VARIABLE_DECLARATION declaration
=>
type_overloaded_variable_declaration (declaration, symbolmapstack, inverse_path, src);
raw::SOURCE_CODE_REGION_FOR_DECLARATION (declaration, src')
=>
{ my (d, symbolmapstack, typevar, update)
=
type_declaration' (
declaration,
symbolmapstack,
inverse_path,
src'
);
( c_markdec (d, src'),
symbolmapstack,
typevar,
update
);
};
raw::PACKAGE_DECLARATIONS _ => bug "strdec";
raw::GENERIC_DECLARATIONS _ => bug "fctdec";
raw::API_DECLARATIONS _ => bug "sigdec";
raw::GENERIC_API_DECLARATIONS _ => bug "fsigdec";
raw::PRE_COMPILE_CODE _ => bug "pre_compile_code";
esac # fun type_declaration'
# Here we handle
# overloaded my * = ( ... )
# statements such as may be found in
# src/lib/core/init/pervasive.pkg #
also
fun type_overloaded_variable_declaration
(
( name, # Name (symbol) of overloaded operator.
type, # Type declared for that operator, e.g. ((X, X) -> X)
alternatives, # The alternative actual ops to which the overloaded op may be resolved.
extend_pre_existing # FALSE normally; TRUE for a "overloaded my * += ( ... )" statement extending a pre-existing overloaded op.
),
symbolmapstack,
inverse_path,
src
)
=
{
pre_existing_alternatives
=
if (not extend_pre_existing)
#
[];
else
case (syx::get (symbolmapstack, name))
#
sxe::NAMED_VARIABLE (vac::OVERLOADED_VARIABLE { name, typescheme, alternatives => REF pre_existing_alternatives } )
=>
{ # NB: We really should check that 'type' above is compatible with 'typescheme' XXX BUGGO FIXME
# We might also at least think about dropping duplicates from the alternatives list...
pre_existing_alternatives;
};
_ =>
{ # A case could be made for signalling an error if
# overloaded my @@ ... += ... ;
# is specified and no preceding definition of '@@'
# is found (as here) but accepting this silently
# allows multiple modules overloading '@@' to be
# included in a largely order-independent manner,
# which I think is more valuable in practice:
#
[];
};
esac;
fi
except
syx::UNBOUND = [];
(tt::type_type (type, symbolmapstack, error_fn, src))
->
(body, typevar_set);
typevars = tvs::get_elements typevar_set;
arity = length typevars;
tj::resolve_typevars_to_typescheme_slots typevars;
tj::drop_macro_expanded_indirections_from_type body;
typescheme = tdt::TYPESCHEME { body, arity };
typechecked_alternatives
=
map type_alternative alternatives
where
fun type_alternative expression
=
type_expression (expression, symbolmapstack, src);
end;
syntax_trees = map #1 typechecked_alternatives;
finalize_deep_syntax_typevar_sets_fns = map #3 typechecked_alternatives;
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
apply (\\ f = f typevar_set)
finalize_deep_syntax_typevar_sets_fns;
alternatives
=
REF (
pre_existing_alternatives
@
(map make_alternative syntax_trees)
)
where
fun make_alternative (ds::SOURCE_CODE_REGION_FOR_EXPRESSION (e, _))
=>
make_alternative e;
make_alternative (ds::VARIABLE_IN_EXPRESSION { var => REF (v as vac::PLAIN_VARIABLE { vartypoid_ref, ... } ), ... })
=>
{ indicator => tj::match_typescheme (typescheme, *vartypoid_ref),
variant => v
};
make_alternative _ => bug "makeOVERLOADdec::alternative";
end;
end;
overloaded_variable
=
vac::OVERLOADED_VARIABLE
{
name,
typescheme,
alternatives
};
( ds::OVERLOADED_VARIABLE_DECLARATION overloaded_variable,
syx::bind (name, sxe::NAMED_VARIABLE overloaded_variable, syx::empty),
tvs::empty,
finalize_deep_syntax_typevar_sets_fn
);
}
# 'stipulate':
#
also
fun type_localdec ((ldecs1, ldecs2), symbolmapstack, inverse_path: ip::Inverse_Path, src)
=
{ (type_declaration' (ldecs1, symbolmapstack, ip::INVERSE_PATH [], src)) -> (ld1, symbolmapstack1, typevar1, finalize_deep_syntax_typevar_sets_fn1);
(type_declaration' (ldecs2, syx::atop (symbolmapstack1, symbolmapstack), inverse_path, src)) -> (ld2, symbolmapstack2, typevar2, finalize_deep_syntax_typevar_sets_fn2);
#
fun finalize_deep_syntax_typevar_sets_fn typevar
=
{ finalize_deep_syntax_typevar_sets_fn1 typevar;
finalize_deep_syntax_typevar_sets_fn2 typevar;
};
( ds::LOCAL_DECLARATIONS (ld1, ld2),
symbolmapstack2,
union (typevar1, typevar2, error_fn src),
finalize_deep_syntax_typevar_sets_fn
);
}
# "include"
#
also
fun type_include_declarations (spaths, symbolmapstack, src)
=
loop (strs, syx::empty)
where
err = error_fn src;
strs = map ( \\ s = { sp = syp::SYMBOL_PATH s;
(sp, fst::find_package_via_symbol_path (symbolmapstack, sp, err));
}
)
spaths;
#
fun loop ([], symbolmapstack) => (ds::INCLUDE_DECLARATIONS strs, symbolmapstack, tvs::empty, no_update);
loop ((_, s) ! r, symbolmapstack) => loop (r, mj::include_package (symbolmapstack, s));
end;
end
# *** VALUE DECLARATIONS ***
#
also
fun type_named_value (raw::SOURCE_CODE_REGION_FOR_NAMED_VALUE (named_value, src), explicit_typevar_refs, symbolmapstack, _)
=>
{ (type_named_value ( named_value, explicit_typevar_refs, symbolmapstack, src))
->
(d, typevars, u);
d' = c_markdec (d, src);
(d', typevars, u);
};
type_named_value (raw::NAMED_VALUE { pattern, expression, is_lazy }, explicit_typevar_refs, symbolmapstack, src)
=>
{ (type_pattern (pattern, symbolmapstack, src)) -> (pattern, pv );
(type_expression (expression, symbolmapstack, src)) -> (expression, ev, update_expression);
expression = if is_lazy delay_expression (force_expression expression);
else expression;
fi;
# When all other typechecking is complete
# we do a final pass computing type variable
# sets and plugging them into the deep syntax
# tree. This reference cell:
#
typevarref = REF [];
#
# becomes NAMED_VALUE.raw_typevars
# in the deep syntax tree and gets
# backpatched by this function:
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ fun a+++b = union (a, b, error_fn src);
fun a---b = diff (a, b, error_fn src);
local_type_vars = (ev+++pv+++explicit_typevar_refs) --- (typevar_set----explicit_typevar_refs);
# explicitTypeVariables should be the second argument to union
# to avoid having the explicit type variables
# macro expanded by the union operation.
downtypevars = local_type_vars +++ (typevar_set----explicit_typevar_refs);
typevarref := tvs::get_elements local_type_vars;
update_expression downtypevars;
};
# WARNING: the following code is trying to propagate
# the PRIMOP varhome through simple value naming.
#
# It is an old hack and should be cleaned up in the future. (ZHONG)
#
# This won't apply if is_lazy==TRUE. (David B MacQueen) XXX BUGGO FIXME
#
pattern
=
case (strip_exp_abs expression)
#
ds::VARIABLE_IN_EXPRESSION { var => REF (vac::PLAIN_VARIABLE { inlining_data => dinfo, ... } ), ... }
=>
if (id::is_simple dinfo)
#
case pattern
#
ds::TYPE_CONSTRAINT_PATTERN (
ds::VARIABLE_IN_PATTERN (
vac::PLAIN_VARIABLE { path, vartypoid_ref, varhome, ... }
),
type
)
=>
ds::TYPE_CONSTRAINT_PATTERN (
ds::VARIABLE_IN_PATTERN (
vac::PLAIN_VARIABLE { path,
vartypoid_ref,
varhome,
inlining_data => dinfo
}
),
type
);
ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { path, vartypoid_ref, varhome, ... } )
=>
ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { path,
vartypoid_ref,
varhome,
inlining_data => dinfo
}
);
_ => pattern;
esac;
else
pattern;
fi;
_ => pattern;
esac;
# David B MacQueen: can the first two cases ever return NULL? XXX BUGGO FIXME
#
fun bind_pattern (ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { varhome, ... } ))
=>
vh::highcode_variable_or_null varhome;
bind_pattern (ds::TYPE_CONSTRAINT_PATTERN (ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { varhome, ... } ), _))
=>
vh::highcode_variable_or_null varhome;
bind_pattern _
=>
NULL;
end;
case (bind_pattern pattern)
#
NULL # David B MacQueen: pattern is not a variable?
=>
( { (trj::replace_pattern_variables (pattern, per_compile_stuff))
->
(newpat, oldvars, newvars);
# NB: Above is the only call of replace_pattern_variables.
b = map (\\ v = ds::VARIABLE_IN_EXPRESSION { var => REF v, typescheme_args => [] }) newvars;
r = ds::CASE_RULE (newpat, trj::tupleexp b);
newexp = ds::CASE_EXPRESSION (expression, complete_bind [r], FALSE);
case oldvars
#
[] => { nvb = ds::VALUE_NAMING { pattern => ds::WILDCARD_PATTERN,
expression => newexp,
raw_typevars => typevarref,
generalized_typevars => []
};
( ds::VALUE_DECLARATIONS [nvb],
[],
finalize_deep_syntax_typevar_sets_fn
);
};
_ => { nv = new_valvar internal_sym;
nvpat = ds::VARIABLE_IN_PATTERN (nv);
nvexp = ds::VARIABLE_IN_EXPRESSION { var => REF nv, typescheme_args => [] };
nvdec = ds::VALUE_DECLARATIONS (
[ ds::VALUE_NAMING { pattern => nvpat,
expression => newexp,
raw_typevars => typevarref,
generalized_typevars => []
}
]
);
#
fun h ( [], _, d)
=>
ds::LOCAL_DECLARATIONS (nvdec, ds::SEQUENTIAL_DECLARATIONS (reverse d));
h (vp ! r, i, d)
=>
{ nvb = ds::VALUE_NAMING { pattern => vp,
expression => trj::tpselexp (nvexp, i),
generalized_typevars => [],
raw_typevars => REF []
};
h (r, i + 1, ds::VALUE_DECLARATIONS ( [nvb] ) ! d);
};
end;
( h (oldvars, 1, []),
oldvars,
finalize_deep_syntax_typevar_sets_fn
);
};
esac;
}
);
THE _
=>
( ds::VALUE_DECLARATIONS (
[ ds::VALUE_NAMING { pattern,
expression,
raw_typevars => typevarref,
generalized_typevars => []
}
]
),
[pattern],
finalize_deep_syntax_typevar_sets_fn
);
esac;
};
end
also
fun type_valdec (named_value, explicit_typevar_refs, symbolmapstack, inverse_path, src)
=
{ explicit_typevar_refs
=
tt::type_typevar_list (explicit_typevar_refs, error_fn, src);
my (ds, pats, finalize_deep_syntax_typevar_sets_fns)
=
fold_backward
( \\ (vdec, (ds1, pats1, update1))
=
{ explicit_typevar_refs
=
tvs::make_typevar_set
(map tdt::copy_typevar_ref explicit_typevar_refs);
(type_named_value (vdec, explicit_typevar_refs, symbolmapstack, src))
->
(d2, pats2, update2);
( d2 ! ds1,
pats2 @ pats1,
update2 ! update1
);
}
)
([], [], [])
named_value;
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
apply (\\ f = f typevar_set)
finalize_deep_syntax_typevar_sets_fns;
( ds::SEQUENTIAL_DECLARATIONS ds,
trj::bind_varp (pats, error_fn src),
tvs::empty,
finalize_deep_syntax_typevar_sets_fn
);
}
also
fun type_fielddec (named_field, explicit_typevar_refs, symbolmapstack, inverse_path, src)
=
{
error_fn
src
err::ERROR
"type-core-language.pkg: field declaration not allowed in non-class package.\n"
err::null_error_body;
# 2009-02-23 CrT: The following code
# is only intended to compile, not to do
# anything sane if run:
#
explicit_typevar_refs
=
tt::type_typevar_list (explicit_typevar_refs, error_fn, src);
#
fun finalize_deep_syntax_typevar_sets_fn typevar
=
();
( ds::SEQUENTIAL_DECLARATIONS [],
symbolmapstack,
tvs::empty,
finalize_deep_syntax_typevar_sets_fn
);
}
also
fun type_named_recursive_values (
raw::SOURCE_CODE_REGION_FOR_RECURSIVELY_NAMED_VALUE (
named_recursive_values,
src
),
symbolmapstack,
_
)
=>
{ (type_named_recursive_values (named_recursive_values, symbolmapstack, src))
->
({ match, type, name }, typevars, finalize_deep_syntax_typevar_sets_fn);
match' = c_markexp (match, src);
( { match => match',
type,
name
},
typevars,
finalize_deep_syntax_typevar_sets_fn
);
};
type_named_recursive_values (
raw::NAMED_RECURSIVE_VALUE { variable_symbol, fixity, expression, null_or_type, is_lazy },
symbolmapstack,
src
)
=>
case (strip_exp_raw_syntax_tree (expression, src))
#
(raw::FN_EXPRESSION _, src')
=>
{ (type_expression (expression, symbolmapstack, src'))
->
(e, ev, finalize_deep_syntax_typevar_sets_fn);
my (t, typevar)
=
case null_or_type
#
THE t1
=>
{ (tt::type_type (t1, symbolmapstack, error_fn, src))
->
(t2, typevar2);
(THE t2, typevar2);
};
NULL => (NULL, tvs::empty);
esac;
case fixity
#
NULL => ();
THE (f, src)
=>
case (fst::find_fixity_by_symbol (symbolmapstack, f) )
fixity::NONFIX => ();
_ => error_fn
src
err::ERROR
( "infix symbol \""
+ sy::name f
+ "\" used where a nonfix identifier was expected"
)
err::null_error_body;
esac;
esac;
( { match => e,
type => t,
name => variable_symbol
},
union (ev, typevar, error_fn src),
finalize_deep_syntax_typevar_sets_fn
);
};
_ => { error_fn
src
err::ERROR
"\\ expression required on righthand-side of my rec"
err::null_error_body;
( { match => dummy_fnexp,
type => NULL,
name => variable_symbol
},
tvs::empty,
no_update
);
};
esac;
end # fun type_named_recursive_values
also
fun type_valrecstrict (rvbs, explicit_typevar_refs, symbolmapstack, src)
=
{ symbolmapstack' = REF (syx::empty: syx::Symbolmapstack);
#
fun make_var src (p as raw::NAMED_RECURSIVE_VALUE { variable_symbol, ... } )
=>
{ v = new_valvar variable_symbol;
nv = new_valvar variable_symbol; # David B MacQueen: What is this for? XXX BUGGO FIXME
# check_bound_constructor (symbolmapstack, var, error_fn src); --- fix bug 1357
symbolmapstack' := syx::bind (variable_symbol, sxe::NAMED_VARIABLE v, *symbolmapstack');
(v, p);
};
make_var _ (p as raw::SOURCE_CODE_REGION_FOR_RECURSIVELY_NAMED_VALUE (named_recursive_values, src))
=>
{ (make_var src named_recursive_values)
->
(v, _);
(v, p);
};
end;
rvbs' = map (make_var src) rvbs;
symbolmapstack'' = syx::atop (*symbolmapstack', symbolmapstack);
my (rvbs, typevars, finalize_deep_syntax_typevar_sets_fns) # "rvbs" is "recursive value bindings" I think.
=
fold_forward
( \\ ((v, named_recursive_values1), (rvbs1, typevars1, update1))
=
{ (type_named_recursive_values (named_recursive_values1, symbolmapstack'', src))
->
(named_recursive_values2, typevar2, update2);
( (v, named_recursive_values2) ! rvbs1,
union (typevar2, typevars1, error_fn src),
update2 ! update1
);
}
)
([], tvs::empty, [])
rvbs';
# When all other typechecking is complete
# we do a final pass computing type variable
# sets and plugging them into the deep syntax
# tree. This reference cell:
#
raw_typevars = REF [];
#
# becomes NAMED_RECURSIVE_VALUE.raw_typevars
# in the deep syntax tree and gets
# backpatched by this function:
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ fun a+++b = union (a, b, error_fn src);
fun a---b = diff (a, b, error_fn src);
local_type_vars = (typevars +++ explicit_typevar_refs) --- (typevars ---- explicit_typevar_refs);
downtypevars = local_type_vars +++ (typevars ---- explicit_typevar_refs);
raw_typevars := tvs::get_elements local_type_vars;
apply (\\ f = f downtypevars)
finalize_deep_syntax_typevar_sets_fns;
};
trj::forbid_duplicates_in_list
( error_fn src,
"duplicate function name in my rec declaration",
(map (\\ (v, { name, ... } ) = name) rvbs)
);
my (ndec, nenv)
=
trj::wrap_named_recursive_values_list(
#
(map (\\ (v, { type, match, name } )
=
ds::NAMED_RECURSIVE_VALUE { variable => v,
expression => match,
null_or_type => type,
raw_typevars,
generalized_typevars => []
}
)
rvbs
),
per_compile_stuff
);
(ndec, nenv, tvs::empty, finalize_deep_syntax_typevar_sets_fn);
} # fun typecheckVALRECstrict
# LAZY: "my rec lazy ..."
also
fun type_valreclazy (rvbs, explicit_typevar_refs, symbolmapstack, src)
=
{ fun split [] => ([], []);
#
split ((raw::NAMED_RECURSIVE_VALUE { variable_symbol, expression, null_or_type, is_lazy, ... } ) ! xs)
=>
{ (split xs) -> (a, b);
#
( (variable_symbol, null_or_type) ! a,
(expression, is_lazy ) ! b
);
};
split ((raw::SOURCE_CODE_REGION_FOR_RECURSIVELY_NAMED_VALUE (x, _)) ! xs)
=>
split (x ! xs);
end; # Losing regions.
(lazy_rec_val_make_ycombinator_declaration (length rvbs))
->
(yvar, decl_y);
(split rvbs) -> (lhss, exps);
argpat = raw::TUPLE_PATTERN (
#
map \\ (symbol, NULL )
=>
raw::VARIABLE_IN_PATTERN [symbol];
(symbol, THE type)
=>
raw::TYPE_CONSTRAINT_PATTERN {
pattern => raw::VARIABLE_IN_PATTERN [symbol],
type_constraint => type
};
end
lhss
);
#
fun type_fn ((expression, is_lazy), (fexps, typevars, finalize_deep_syntax_typevar_sets_fns))
=
{ (type_pattern (argpat, symbolmapstack, src))
->
(p, typevar1);
symbolmapstack' = syx::atop (trj::bind_varp ([p], error_fn src), symbolmapstack);
(type_expression (expression, symbolmapstack', src))
->
(e, typevar2, finalize_deep_syntax_typevar_sets_fn);
( ds::FN_EXPRESSION (
complete_match
[ ds::CASE_RULE ( p,
if is_lazy e;
else delay_expression e;fi
)
],
tdt::UNDEFINED_TYPOID
)
!
fexps,
union (union (typevar1, typevar2, error_fn src), typevars, error_fn src),
finalize_deep_syntax_typevar_sets_fn ! finalize_deep_syntax_typevar_sets_fns
);
};
(fold_backward type_fn ([], tvs::empty, []) exps)
->
(fns, typevars, finalize_deep_syntax_typevar_sets_fns);
lhs_syms = map #1 lhss; # lefthand-side symbols.
lhs_vars = map new_valvar lhs_syms;
# Copied from original typecheckVALRECdec
# When all other typechecking is complete
# we do a final pass computing type variable
# sets and plugging them into the deep syntax
# tree. This reference cell:
#
raw_typevars = REF [];
#
# becomes NAMED_VALUE.raw_typevars
# in the deep syntax tree and gets
# backpatched by this function:
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
{ fun a+++b = union (a, b, error_fn src);
fun a---b = diff (a, b, error_fn src);
local_type_vars = (typevars +++ explicit_typevar_refs) --- (typevars ---- explicit_typevar_refs);
downtypevars = local_type_vars +++ (typevars ---- explicit_typevar_refs);
raw_typevars := tvs::get_elements local_type_vars;
apply (\\ f = f downtypevars)
finalize_deep_syntax_typevar_sets_fns;
};
decl_app_y
=
ds::VALUE_DECLARATIONS
[ ds::VALUE_NAMING { pattern => trj::tuplepat (map ds::VARIABLE_IN_PATTERN lhs_vars),
expression => ds::APPLY_EXPRESSION { operator => ds::VARIABLE_IN_EXPRESSION { var => REF yvar, typescheme_args => [] }, operand => trj::tupleexp fns },
raw_typevars,
generalized_typevars => []
}
];
#
fun force_strict ((symbol, var1, is_lazy), (vbs, vars))
=
{ var2 = new_valvar symbol;
#
named_value
=
if is_lazy
#
ds::VALUE_NAMING { pattern => ds::VARIABLE_IN_PATTERN var2,
expression => ds::VARIABLE_IN_EXPRESSION { var => REF var1, typescheme_args => [] },
raw_typevars => REF [],
generalized_typevars => []
};
else
ds::VALUE_NAMING { pattern => ds::APPLY_PATTERN ( mtt::dollar_valcon, [], (ds::VARIABLE_IN_PATTERN var2)),
expression => ds::VARIABLE_IN_EXPRESSION { var => REF var1, typescheme_args => [] },
raw_typevars => REF [],
generalized_typevars => []
};
fi;
( named_value ! vbs,
var2 ! vars
);
};
#
fun zip3 (x ! xs, y ! ys, z ! zs) => (x, y, z) ! zip3 (xs, ys, zs);
zip3 (NIL, _, _) => NIL;
zip3 _ => bug "zip3";
end;
my (vbs, vars)
=
fold_backward
force_strict
([], [])
(zip3 (lhs_syms, lhs_vars, map #2 exps));
symbolmapstack'
=
fold_forward
( \\ ((s, v), symbolmapstack)
=
syx::bind (s, sxe::NAMED_VARIABLE v, symbolmapstack)
)
syx::empty
(paired_lists::zip (lhs_syms, vars));
deep_syntax_tree = ds::LOCAL_DECLARATIONS (ds::SEQUENTIAL_DECLARATIONS [decl_y, decl_app_y], ds::VALUE_DECLARATIONS vbs);
show_declaration ("typecheckVALREClazy: ", deep_syntax_tree, symbolmapstack');
( deep_syntax_tree,
symbolmapstack',
tvs::empty, # ? XXX QUERO FIXME
finalize_deep_syntax_typevar_sets_fn
);
} # fun type_valreclazy
also
fun type_valrecdec ( rvbs: List( raw::Named_Recursive_Value ),
explicit_typevar_refs,
symbolmapstack,
inverse_path: ip::Inverse_Path,
src
)
=
{ explicit_typevar_refs
=
tvs::make_typevar_set (
tt::type_typevar_list (
explicit_typevar_refs,
error_fn,
src
)
);
#
fun is_lazy (raw::NAMED_RECURSIVE_VALUE { is_lazy, ... } )
=>
is_lazy;
is_lazy (raw::SOURCE_CODE_REGION_FOR_RECURSIVELY_NAMED_VALUE (named_recursive_values, _) )
=>
is_lazy named_recursive_values;
end;
if (list::exists is_lazy rvbs) type_valreclazy (rvbs, explicit_typevar_refs, symbolmapstack, src);
else type_valrecstrict (rvbs, explicit_typevar_refs, symbolmapstack, src);
fi;
}
also
fun type_seqdec (ds, symbolmapstack, inverse_path: ip::Inverse_Path, src)
=
{ my (ds1, symbolmapstack1, typevar1, finalize_deep_syntax_typevar_sets_fns)
=
fold_forward
( \\ (decl2, (ds2, symbolmapstack2, typevars2, update2))
=
{ my (d3, symbolmapstack3, typevars3, update3)
=
type_declaration' (
decl2,
syx::atop (symbolmapstack2, symbolmapstack),
inverse_path,
src
);
( d3 ! ds2,
syx::atop (symbolmapstack3, symbolmapstack2),
union (typevars3, typevars2, error_fn src),
update3 ! update2
);
}
)
([], syx::empty, tvs::empty, [])
ds;
#
fun finalize_deep_syntax_typevar_sets_fn typevar_set
=
apply (\\ f = f typevar_set)
finalize_deep_syntax_typevar_sets_fns;
( ds::SEQUENTIAL_DECLARATIONS (reverse ds1),
symbolmapstack1,
typevar1,
finalize_deep_syntax_typevar_sets_fn
);
}
# Translation from raw syntax to deep syntax
# of (in the most general case) a sequence of
# mutually recursive function definitions, each
# composed of a sequence of
# fun pattern => expression
# clauses.
#
# We do this via a two-phase process consisting of:
#
# o An analysis phase
# which locates all the functions and
# creates symbol table definitions for
# them with place-holders where their
# eventual translations will be;
#
# o A synthesis phase
# which does the actual translation from
# raw syntax to deep syntax, armed with
# the above-gathered information.
#
# Input:
# 'functionNamings'
# is in general the raw syntax parsetree
# for something like
#
# fun foo this = expression1;
# | foo that = expression2;
#
# and bar this = expression3;
# | bar that = expression4;
#
# It takes the form essentially of a list of
# NAMED_FUNCTION nodes, one per function
# defined -- in the above case, two, one for 'foo',
# one for 'bar'.
#
# 'explicitTypeVariables'
# is almost always NIL in practice -- it supports
# the very rarely used option of preceding a statement
# with a list of type variables to be used in it.
#
# 'symbolmapstack'
# is the topl-level symbol table passed down
# ultimately from read-eval-print-loop-g.pkg
# or such, augmented by additional local declarations
# as appropriate.
#
# 'inverse_path'
# appears to be something vaguely like the
# (inverse) symbol leading to the package
# (or whatever) currently being compiled.
# It is hard to find any uses of it. :-/ XXX BUGGO FIXME
#
# 'src' ("source_code_region")
# is as usual just the line-column source-code
# range corresponding to the statement being
# typechecked, for diagnostic message purposes.
#
# Result:
# We return a quadruple
#
# (deepSyntax, resultSymbolmapstack, typeVariableSet, update)
#
# where:
#
# 'deepSyntax'
# is the typechecked version of our 'functionNamings' argument.
#
# 'resultSymbolmapstack'
# is XXX BUGGO FIXME
#
# 'typeVariableSet'
# is XXX BUGGO FIXME
#
# 'update'
# is XXX BUGGO FIXME
also
fun type_smlfundec (named_functions, explicit_typevar_refs, symbolmapstack, inverse_path, src)
=
{ explicit_typevar_refs
=
tvs::make_typevar_set (
tt::type_typevar_list (
explicit_typevar_refs,
error_fn,
src
)
);
# Analysis Phase processing of a function declaration.
#
# Here we analyse the function's raw-syntax tree to:
#
# o Check for syntax errors,
#
# o Determine the function name,
#
# o Create a variables_and_constructors::variable::PLAIN_VARIABLE
# symbolmapstack-entry record to represent the function being defined, and
#
# o Enter it into our symbol table.
#
# Our first argument is just the relevant source
# code region, for error diagnostic purposes.
#
# Our second argument is a pair (input, result) where:
#
# 'input' is the raw syntax tree for the sequence
#
# fun foo this = expression1;
# | foo that = expression2;
# ...
#
# naming some function to 'foo'.
#
# This will consist essentially of an
# NAMED_FUNCTION node containing a list of
# PATTERN_CLAUSE nodes -- in the above
# example two such nodes, one per source line.
#
# 'result' is the result so far, a pair (functions, symbolmapstack)
# in which:
#
# 'functions'
# is a list containing one
# (symbolmapstack_entry, pattern_clauses, source_region)
# triple per function definition
#
# 'symbolmapstack'
# has been updated with entries for these functions.
#
# We update the 'result' argument and return it as our result.
#
fun digest_one_named_function _ (raw::SOURCE_CODE_REGION_FOR_NAMED_FUNCTION (named_function, named_functionregion), result_so_far)
=>
digest_one_named_function named_functionregion (named_function, result_so_far);
digest_one_named_function named_functionregion (raw::NAMED_FUNCTION { pattern_clauses, is_lazy, kind, null_or_type }, (clause_list_so_far, symbolmapstack'))
=>
{ fun get_fixity (THE f) => fst::find_fixity_by_symbol (symbolmapstack, f);
get_fixity NULL => fixity::NONFIX;
end;
# Check that 'fixity' is -not- NONFIX,
# then return 'item':
#
fun ensure_infix { item, fixity, source_code_region }
=
{ case (get_fixity fixity)
#
fixity::NONFIX
=>
error_fn
source_code_region
err::ERROR
"infix operator required, or delete parentheses"
err::null_error_body;
_ => ();
esac;
item;
};
# Check that 'fixity' is NONFIX,
# then return 'item':
#
fun ensure_nonfix { item, fixity, source_code_region }
=
{ case (get_fixity fixity, fixity)
#
(fixity::NONFIX, _) => ();
(_, THE symbol)
=>
error_fn
source_code_region
err::ERROR
( "infix operator \""
+ sy::name symbol
+ "\" used without \"op\" in fun declaration"
)
err::null_error_body;
_ => bug "ensureNonfix";
esac;
item;
};
# Extract the function "name"
# (a value-space symbol::symbol)
# from the "pattern" part of a
# "fun pattern => expression"
# raw syntax pattern clause.
#
# This basically just means looking
# for the root VARIABLE_IN_PATTERN node:
#
fun get_function_name (raw::SOURCE_CODE_REGION_FOR_PATTERN (p, src), _)
=>
get_function_name (p, src);
get_function_name (raw::VARIABLE_IN_PATTERN [v], _)
=>
v;
get_function_name (_, src)
=>
{ error_fn
src
err::ERROR
"illegal function symbol in clause"
err::null_error_body;
trj::bogus_id;
};
end;
# See comment on "fun get_fun_name_and_argument_list", below.
#
fun get_fun_name_and_argument_list'
( { item => raw::PRE_FIXITY_PATTERN [ a,
b as { source_code_region, ... },
c
],
...
}
!
rest
)
=>
( get_function_name (ensure_infix b, source_code_region),
tuple_pattern (ensure_nonfix a, ensure_nonfix c) ! map ensure_nonfix rest
);
get_fun_name_and_argument_list' [ { item, source_code_region, ... } ]
=>
{ error_fn
source_code_region
err::ERROR
"can't find function arguments in clause"
err::null_error_body;
( get_function_name (item, source_code_region),
[ raw::WILDCARD_PATTERN ]
);
};
get_fun_name_and_argument_list' ((a as { source_code_region, ... } ) ! rest)
=>
( get_function_name (ensure_nonfix a, source_code_region),
map ensure_nonfix rest
);
get_fun_name_and_argument_list' []
=>
bug "get_fun_name_and_argument_list':[]";
end;
# XXX QUERO FIXME Is there any need for the above to be a separate fun from below?
# We're given the 'patterns' list
# from an PATTERN_CLAUSE
# raw-syntax node representing a
#
# fun pattern = expression
#
# parsetree or the like.
#
# We need to return a pair (name, args) where
#
# 'name' is the symbol naming the
# function being defined and
#
# 'args' is the list of (raw syntax trees for the)
# arguments to which that function
# is being applied.
#
fun get_fun_name_and_argument_list ( { item => raw::SOURCE_CODE_REGION_FOR_PATTERN (pattern, _), source_code_region, fixity } ! rest)
=>
get_fun_name_and_argument_list ( { item => pattern,
source_code_region,
fixity
}
!
rest
);
get_fun_name_and_argument_list ( patterns as [ a as { source_code_region => ra, ... },
b as { item, fixity, source_code_region },
c
]
)
=>
case (get_fixity fixity)
#
fixity::NONFIX => get_fun_name_and_argument_list' patterns;
_ => ( get_function_name (item, source_code_region),
[ tuple_pattern ( ensure_nonfix a,
ensure_nonfix c
)
]
);
esac;
get_fun_name_and_argument_list patterns
=>
get_fun_name_and_argument_list' patterns;
end;
# Map the raw syntax tree
# representing one
#
# fun foo this = expression;
#
# input expression to the five-field
# record with which we will
# represent it henceforth:
#
fun digest_pattern_clause (raw::PATTERN_CLAUSE { patterns, result_type, expression } )
=
{ (get_fun_name_and_argument_list patterns)
->
( function_symbol,
raw_syntax_argument_patterns
);
{ kind => STRICT,
function_symbol,
raw_syntax_argument_patterns,
result_type,
raw_syntax_expression => expression
};
};
# Given a list of raw-syntax
# PATTERN_CLAUSE nodes,
# each representing one line of a
#
# fun foo this = expression1;
# | foo that = expression2;
# ...
#
# function definition, sanity-check them all,
# convert each to more convenient record form,
# and construct a result list
# 'digestedSmlPatternClauses'
# of those records.
#
# Each entry in this list is a triple
# (name, patternClauses, sourceRegion)
# representing one function definition where
# 'patternClauses' is in turn a list of records
# { kind, functionSymbol, rawSyntaxArgumentPatterns, result_type, rawSyntaxExpression }
# and 'rawSyntaxArgumentPatterns' is in its turn a list of
# raw-syntax pattern parsetrees.
#
# As a convenience, we also return the
# value-space symbol::symbol naming the
# function being defined, extracted
# from the pattern clauses:
#
my (digested_pattern_clauses, function_symbol)
=
case (map digest_pattern_clause pattern_clauses)
#
[] => bug "type-core-language: No clauses";
(l as ( { function_symbol, ... } ! _))
=>
(l, function_symbol);
esac;
# Syntax check:
# Given our 'digestedSmlPatternClauses' list of
# { kind, functionSymbol, rawSyntaxArgumentPatterns, result_type, rawSyntaxExpression }
# records representing the lines of a
#
# fun foo this = expression1;
# | foo that = expression2;
# ...
#
# function definition, check that
# all the 'foo' are the same symbol:
#
if ( list::exists
( \\ { function_symbol=>my_function_symbol, ... }
=
not (sy::eq (function_symbol, my_function_symbol))
)
digested_pattern_clauses
)
error_fn
named_functionregion
err::ERROR
"clauses don't all have same function name"
err::null_error_body;
fi;
# David B MacQueen: fix bug 1357 -- allow 'fun' to rebind data constructor names:
# checkBoundConstructor (symbolmapstack, functionSymbol, error_fn function_namingregion);
# Create a symbol table entry record for
# the function being defined, of type
#
# variables_and_constructors::variable::PLAIN_VARIABLE
#
# NB: Actually entering this record into a
# symbol table is a separate operation,
# done later.
#
fun_symbolmapstack_entry
=
new_valvar function_symbol;
# Syntax check:
# Given our 'digestedSmlPatternClauses' list of
#
# { kind, functionSymbol, rawSyntaxArgumentPatterns, result_type, rawSyntaxExpression }
#
# records representing the lines of a
#
# fun foo this = expression1;
# | foo that = expression2;
# ...
#
# function definition, check that
# 'this', 'that' etc are all the
# same arity (number of arguments):
#
&nbs