## typer-junk.pkg
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib# The center 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 for utility functions to build
# deep syntax trees from raw syntax trees.
### "Strunk felt that the reader was in serious
### trouble most of the time, a man floundering
### in a swamp, and that it was the duty of anyone
### attempting to write English to drain the swamp
### quickly and get his man up on dry ground, or
### at least throw him a rope."
###
### -- EB White
stipulate
package di = debruijn_index; # debruijn_index is from src/lib/compiler/front/typer/basics/debruijn-index.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 xet = eq_types; # eq_types is from src/lib/compiler/front/typer/types/eq-types.pkg package fis = 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 lms = list_mergesort; # list_mergesort is from src/lib/src/list-mergesort.pkg package mj = module_junk; # module_junk is from src/lib/compiler/front/typer-stuff/modules/module-junk.pkg package pds = prettyprint_deep_syntax; # prettyprint_deep_syntax is from src/lib/compiler/front/typer/print/prettyprint-deep-syntax.pkg package pj = print_junk; # print_junk is from src/lib/compiler/front/basics/print/print-junk.pkg package raw = raw_syntax; # raw_syntax is from src/lib/compiler/front/parser/raw-syntax/raw-syntax.pkg package rsj = raw_syntax_junk; # raw_syntax_junk is from src/lib/compiler/front/parser/raw-syntax/raw-syntax-junk.pkg package rwv = rw_vector; # rw_vector is from src/lib/std/src/rw-vector.pkg package sta = stamp; # stamp is from src/lib/compiler/front/typer-stuff/basics/stamp.pkg package sxe = symbolmapstack_entry; # symbolmapstack_entry is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack-entry.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package 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 tj = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.pkg package tvs = typevar_set; # typevar_set is from src/lib/compiler/front/typer/main/type-variable-set.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package uds = unparse_deep_syntax; # unparse_deep_syntax is from src/lib/compiler/front/typer/print/unparse-deep-syntax.pkg package ut = unparse_type; # unparse_type is from src/lib/compiler/front/typer/print/unparse-type.pkg package vac = variables_and_constructors; # variables_and_constructors is from src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg #
# include package print_junk;
herein
package typer_junk
: (weak) Typer_Junk # Typer_Junk is from src/lib/compiler/front/typer/main/typer-junk.api {
# Debugging
say = control_print::say;
# debugging = REF FALSE;
debugging = typer_control::typer_junk_debugging; # REF FALSE
fun if_debugging_say (msg: String)
=
if *debugging say msg; say "\n"; fi;
fun bug msg
=
err::impossible ("typer_junk: " + msg);
print_depth = control_print::print_depth;
prettyprint_declaration = pds::prettyprint_declaration (syx::empty, NULL);
prettyprint_expression = pds::prettyprint_expression (syx::empty, NULL);
prettyprint_pattern = pds::prettyprint_pattern syx::empty;
unparse_typoid = ut::unparse_typoid syx::empty;
unparse_typevar_ref = ut::unparse_typevar_ref syx::empty;
unparse_pattern = uds::unparse_pattern syx::empty;
unparse_expression = uds::unparse_expression (syx::empty, NULL);
unparse_rule = uds::unparse_rule (syx::empty, NULL);
unparse_named_value = uds::unparse_named_value (syx::empty, NULL);
unparse_recursive_named_value = uds::unparse_recursively_named_value (syx::empty, NULL);
unparse_declaration
=
(\\ stream
=
\\ d
=
uds::unparse_declaration
(syx::empty, NULL)
stream
(d, *print_depth)
);
fun if_debugging_unparse_declaration (msg, declaration)
=
if *debugging
typer_debugging::with_internals
(\\ () = typer_debugging::debug_print debugging (msg, unparse_declaration, declaration));
fi;
fun if_debugging_unparse_typoid (msg, type)
=
if *debugging
typer_debugging::with_internals
(\\ () = typer_debugging::debug_print debugging (msg, unparse_typoid, type));
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! :-)
typer_debugging::with_internals
(\\ () = typer_debugging::debug_print debugging (msg, unparse_typevar_ref, typevar_ref));
fi;
fun if_debugging_unparse_pattern (msg, pattern)
=
if *debugging
typer_debugging::with_internals
(\\ () = typer_debugging::debug_print debugging (msg, unparse_pattern, pattern));
fi;
fun if_debugging_unparse_expression (msg, expression)
=
if *debugging
typer_debugging::with_internals
(\\ () = typer_debugging::debug_print debugging (msg, unparse_expression, expression));
fi;
fun if_debugging_prettyprint_expression (msg, expression)
=
if *debugging
typer_debugging::with_internals
(\\ () = typer_debugging::debug_print debugging (msg, prettyprint_expression, expression));
fi;
fun if_debugging_prettyprint_pattern (msg, pattern)
=
if *debugging
typer_debugging::with_internals
(\\ () = typer_debugging::debug_print debugging (msg, prettyprint_pattern, pattern));
fi;
fun if_debugging_prettyprint_declaration (msg, declaration)
=
if *debugging
typer_debugging::with_internals
(\\ () = typer_debugging::debug_print debugging (msg, prettyprint_declaration, declaration));
fi;
fun for' l f
=
apply f l;
fun discard _ = ();
fun single x = [x];
internal_sym = special_symbols::internal_var_id;
Syntactic_Typechecking_Context
= AT_TOPLEVEL # At top level -- not inside any module, rigid.
| IN_PACKAGE # Inside a rigid package, i.e. not inside any generic package body.
| IN_API # Within a api body.
| IN_GENERIC # Inside a generic package.
{ debruijn_depth: di::Debruijn_Depth,
flex: sta::Stamp -> Bool # Predicate recognizing flexible stamps.
}; # Nomenclature: "Definition of SML" calls typcons from apis "flexible" an all others "rigid".
Per_Compile_Stuff
=
per_compile_stuff::Per_Compile_Stuff( ds::Declaration );
fun new_valvar (s, issue_highcode_codetemp)
=
vac::make_ordinary_variable (s, vh::named_varhome (s, issue_highcode_codetemp));
fun smash f l
=
fold_backward h (NIL, NIL, NIL) l
where
fun h (a, (pl, oldl, newl))
=
{ my (p, old, new) = f a;
( p ! pl,
old @ oldl,
new @ newl
);
};
end;
stipulate
fun uniq ((a0 as (a, _, _)) ! (r as (b, _, _) ! _))
=>
if (sy::eq (a, b) ) uniq r;
else a0 ! uniq r;
fi;
uniq l
=>
l;
end;
fun gtr ((a, _, _), (b, _, _))
=
{ a' = sy::name a;
b' = sy::name b;
a0 = string::get_byte_as_char (a', 0);
b0 = string::get_byte_as_char (b', 0);
if (char::is_digit a0)
if (char::is_digit b0 ) size a' > size b' or size a' == size b' and a' > b';
else FALSE; fi;
else
if (char::is_digit b0 ) TRUE;
else (a' > b'); fi;
fi;
};
herein
fun sort3 x
=
uniq (lms::sort_list gtr x);
end;
equalsym = sy::make_value_symbol "=";
anon_param_name = sy::make_package_symbol "<AnonParam>";
# following could go in deep_syntax
bogus_id = sy::make_value_symbol "*bogus*";
bogus_exn_id = sy::make_value_symbol "*Bogus*";
truepat = ds::CONSTRUCTOR_PATTERN ( mtt::true_valcon, [] );
trueexp = ds::VALCON_IN_EXPRESSION { valcon => mtt::true_valcon, typescheme_args => [] };
falsepat = ds::CONSTRUCTOR_PATTERN ( mtt::false_valcon, [] );
falseexp = ds::VALCON_IN_EXPRESSION { valcon => mtt::false_valcon, typescheme_args => [] };
nilpat = ds::CONSTRUCTOR_PATTERN ( mtt::nil_valcon, [] );
nilexp = ds::VALCON_IN_EXPRESSION { valcon => mtt::nil_valcon, typescheme_args => [] };
conspat = \\ pattern = ds::APPLY_PATTERN ( mtt::cons_valcon, [], pattern );
consexp = ds::VALCON_IN_EXPRESSION { valcon => mtt::cons_valcon, typescheme_args => [] };
void_expression
=
dsj::void_expression;
void_pattern
=
ds::RECORD_PATTERN
{
fields => NIL,
is_incomplete => FALSE,
type_ref => REF tdt::UNDEFINED_TYPOID
};
bogus_expression
=
ds::VARIABLE_IN_EXPRESSION
{
var => REF (vac::make_ordinary_variable (bogus_id, vh::null_varhome)),
typescheme_args => []
};
# Verify that all the elements of a list are unique,
# By sorting and then equality-checking adjacent pairs:
#
fun forbid_duplicates_in_list (err, message, names)
=
f names'
where
names' = lms::sort_list sy::symbol_gt names;
fun f (x ! y ! rest)
=>
{ if (sy::eq (x, y)) err err::ERROR (message + ": " + sy::name x) err::null_error_body; fi;
f (y ! rest);
};
f _ => ();
end;
end;
# Extract all the variable namings from a pattern,
# and return as a new Symbolmapstack.
#
# NOTE: the "free_or_vars" function in
# type-core-language.pkg should
# probably be merged with this. XXX BUGGO FIXME
#
fun bind_varp (patlist, err)
=
{ vl = REF (NIL: List( sy::Symbol ));
#
symbolmapstack = REF (syx::empty: syx::Symbolmapstack);
fun f (ds::VARIABLE_IN_PATTERN (v as vac::PLAIN_VARIABLE { path => syp::SYMBOL_PATH [name], inlining_data, ... } ))
=>
{ if (sy::eq (name, equalsym)) # Major hack XXX BUGGO FIXME
# if id::is_baseop_info (id::fromExn inlining_data) then ()
# else
err err::WARNING "renaming =" err::null_error_body;
fi;
symbolmapstack := syx::bind (name, sxe::NAMED_VARIABLE v, *symbolmapstack);
vl := name ! *vl;
};
f (ds::RECORD_PATTERN { fields, ... } ) => apply (\\(_, pattern)=>f pattern; end ) fields;
f (ds::VECTOR_PATTERN (patterns, _)) => apply f patterns;
f (ds::APPLY_PATTERN (_, _, pattern)) => f pattern;
f (ds::TYPE_CONSTRAINT_PATTERN (pattern, _)) => f pattern;
f (ds::AS_PATTERN (p1, p2)) => { f p1; f p2;};
f (ds::OR_PATTERN (p1, p2)) => { f p1; bind_varp([p2], err); ();};
f _ => ();
end;
apply f patlist;
forbid_duplicates_in_list (err, "duplicate variable in pattern (s)", *vl);
*symbolmapstack;
};
# fun isPrimPattern (ds::VARIABLE_IN_PATTERN { info, ... } ) = ii::is_baseop_info (info)
# | isPrimPattern (ds::COSTRAINTpat (ds::VARIABLE_IN_PATTERN { info, ... }, _)) = ii::is_baseop_info (info)
# | isPrimPattern _ = FALSE;
# replace_pattern_variables:
# "alpha convert" a pattern, replacing old variables by
# new ones, with new HIGHCODE_VARIABLE varhomees.
# Returns the converted pattern, the list of old variables (VARpats)
# and the list of new variables (VALvars).
# called only once, in typecheckValueNaming in elabcore.sml
fun replace_pattern_variables (prettyprint, per_compile_stuff as { issue_highcode_codetemp, ... } : Per_Compile_Stuff)
=
{ my oldnew: Ref( List( (ds::Case_Pattern, vac::Variable) ) )
= REF NIL;
fun f (p as ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { varhome => acc, inlining_data, vartypoid_ref => REF type', path } ))
=>
{ fun find ((ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { varhome => acc', ... } ), x) ! rest, v)
=>
case (vh::highcode_variable_or_null acc') # David B MacQueen: can this return NULL? XXX BUGGO FIXME
#
THE w
=>
if (v == w) x;
else find (rest, v);
fi;
# David B MacQueen: Can the TRUE branch happen? XXX BUGGO FIXME
# ie. two variables with same highcode_variable
# in a pattern?
_ => find (rest, v);
esac;
find (_ ! rest, v)
=>
find (rest, v);
find (NIL, v) # David B MacQueen: assert this rule always applies ? XXX FIXME BUGGO
=>
{ x = vac::PLAIN_VARIABLE
{
varhome => vh::duplicate_varhome (v, issue_highcode_codetemp),
inlining_data,
#
vartypoid_ref => REF type',
path
};
oldnew := (p, x) ! *oldnew;
x;
};
end;
case (vh::highcode_variable_or_null acc)
#
THE v => ds::VARIABLE_IN_PATTERN (find (*oldnew, v));
_ => bug "unexpected varhome in replace_pattern_variables";
esac;
};
f (ds::RECORD_PATTERN { fields, is_incomplete, type_ref } )
=>
ds::RECORD_PATTERN {
fields => map (\\ (l, p) => (l, f p); end ) fields,
is_incomplete,
type_ref
};
f (ds::VECTOR_PATTERN (patterns, t)) => ds::VECTOR_PATTERN (map f patterns, t);
f (ds::APPLY_PATTERN (d, c, p)) => ds::APPLY_PATTERN (d, c, f p);
f (ds::OR_PATTERN (a, b)) => ds::OR_PATTERN (f a, f b);
f (ds::TYPE_CONSTRAINT_PATTERN (p, t)) => ds::TYPE_CONSTRAINT_PATTERN (f p, t);
f (ds::AS_PATTERN (p, q)) => ds::AS_PATTERN (f p, f q);
f p => p;
end;
np = f prettyprint;
fun h ((a, b) ! r, x, y) => h (r, a ! x, b ! y);
h ( [], x, y) => (np, x, y);
end;
h (*oldnew, [], []);
};
# Sort the labels in a record.
# The order is redefined to take
# the usual ordering on numbers
# expressed by strings (tuples):
#
stipulate
fun sort x
=
lms::sort_list
( \\ ((a, _), (b, _))
=>
tj::label_is_greater_than (a, b); end
)
x;
herein
fun sort_record (l, err)
=
{ forbid_duplicates_in_list (err, "duplicate label in record", map #1 l);
sort l;
};
end;
fun make_record_expression (fields, err)
=
ds::RECORD_IN_EXPRESSION (f (0, fields'))
where
fields' = map (\\ (id, expression) = (id, (expression, REF 0)))
fields;
fun assign (i, (_, (_, r)) ! tl)
=>
{ r := i;
assign (i+1, tl);
};
assign (_, NIL)
=>
();
end;
fun f (i, (id, (expression, REF n)) ! rest)
=>
( ds::NUMBERED_LABEL { name => id, number => n },
expression
)
!
f (i+1, rest);
f (_, NIL)
=>
NIL;
end;
assign (0, sort_record (fields', err));
end;
tupleexp = dsj::tupleexp;
/*
fun TUPLE_IN_EXPRESSION l
=
{ fun addlabels (i, e ! r) =
(LABEL { number=i - 1, name=(tuples::number_to_label i) }, e)
! addlabels (i+1, r)
| addlabels(_, NIL) = NIL;
ds::RECORD_IN_EXPRESSION (addlabels (1, l));
}
*/
fun tpselexp (e, i)
=
{ lab = ds::NUMBERED_LABEL {
number => i - 1,
name => (tuples::number_to_label i)
};
ds::RECORD_SELECTOR_EXPRESSION (lab, e);
};
# Adds a default case to a list of rules.
# If given list is marked, all ordinarily-marked expressions
# in default case are also marked, using end of given list
# as location.
#
# KLUDGE! The debugger distinguishes marks in the default case by
# the fact that start and end locations for these marks
# are the same!
#
fun complete_match'' rule [ r as ds::CASE_RULE ( pattern, ds::SOURCE_CODE_REGION_FOR_EXPRESSION (_, (_, right))) ]
=>
[ r, rule (\\ expression => ds::SOURCE_CODE_REGION_FOR_EXPRESSION (expression, (right, right)); end ) ];
complete_match'' rule [r as ds::CASE_RULE (pattern, ds::TYPE_CONSTRAINT_EXPRESSION (ds::SOURCE_CODE_REGION_FOR_EXPRESSION (_, (_, right)), _)) ]
=>
[ r, rule (\\ expression => ds::SOURCE_CODE_REGION_FOR_EXPRESSION (expression, (right, right)); end ) ];
complete_match'' rule [r]
=>
[ r, rule (\\ expression = expression) ];
complete_match'' rule (a ! r)
=>
a ! complete_match'' rule r;
complete_match'' _ _
=>
bug "completeMatch''";
end;
fun complete_match' (ds::CASE_RULE (p, e))
=
complete_match'' (\\ marker = ds::CASE_RULE (p, marker e));
fun complete_match (symbolmapstack, name)
=
complete_match''
( \\ marker
=
ds::CASE_RULE (
ds::WILDCARD_PATTERN,
marker (
ds::RAISE_EXPRESSION (
ds::VALCON_IN_EXPRESSION {
valcon => core_access::get_exception (symbolmapstack, name),
typescheme_args => []
},
tdt::UNDEFINED_TYPOID
)
)
)
);
trivial_complete_match = complete_match (syx::empty, "MATCH");
tuplepat = dsj::tuplepat;
/*
fun TUPLEPAT l
=
{ fun addlabels (i, e ! r) = (tuples::number_to_label i, e) ! addlabels (i+1, r)
| addlabels(_, NIL) = NIL;
RECORD_PATTERN { fields => addlabels (1, l), is_incomplete => FALSE, type_ref => REF tdt::UNDEFINED_TYPOID };
}
*/
fun wrap_recdec (rvbs, per_compile_stuff as { issue_highcode_codetemp, ... } : Per_Compile_Stuff)
=
{ fun g ( ds::NAMED_RECURSIVE_VALUE {
variable => v
as
vac::PLAIN_VARIABLE {
path => syp::SYMBOL_PATH [ symbol ],
...
},
...
},
nvars
)
=>
{ nv = new_valvar (symbol, issue_highcode_codetemp);
( (v, nv, symbol) ! nvars);
};
g _
=>
bug "wrapRECdecGen: NAMED_RECURSIVE_VALUE";
end;
vars = fold_backward g [] rvbs;
odec = ds::RECURSIVE_VALUE_DECLARATIONS rvbs;
raw_typevars
=
case rvbs
#
(ds::NAMED_RECURSIVE_VALUE { raw_typevars, ... } ) ! _
=>
raw_typevars;
_ => bug "unexpected empty rvbs list in wrap_recdec";
esac;
declarations
=
case vars
#
[ (v, nv, symbol) ]
=>
ds::VALUE_DECLARATIONS [
#
ds::VALUE_NAMING
{
pattern => ds::VARIABLE_IN_PATTERN nv,
expression => ds::LET_EXPRESSION (odec, ds::VARIABLE_IN_EXPRESSION { var => REF v, typescheme_args => [] }),
raw_typevars,
generalized_typevars => []
}
];
_
=>
{ vs = map ( \\ (v, _, _)
=
ds::VARIABLE_IN_EXPRESSION { var => REF v, typescheme_args => [] }
)
vars;
rootv = new_valvar (internal_sym, issue_highcode_codetemp);
rvexp = ds::VARIABLE_IN_EXPRESSION { var => REF rootv, typescheme_args => [] };
nvdec = ds::VALUE_DECLARATIONS
[
ds::VALUE_NAMING
{
pattern => ds::VARIABLE_IN_PATTERN rootv,
expression => ds::LET_EXPRESSION (odec, tupleexp vs),
raw_typevars,
generalized_typevars => []
}
];
h (vars, 1, [])
where
fun h ([], _, d)
=>
ds::LOCAL_DECLARATIONS (nvdec, ds::SEQUENTIAL_DECLARATIONS (reverse d));
h ((_, nv, _) ! r, i, d)
=>
{ nvb = ds::VALUE_NAMING
{
pattern => ds::VARIABLE_IN_PATTERN nv,
expression => tpselexp (rvexp, i),
raw_typevars => REF [],
generalized_typevars => []
};
h (r, i + 1, ds::VALUE_DECLARATIONS ([ nvb ]) ! d);
};
end;
end;
};
esac;
( vars,
declarations
);
};
# Commented out 2009-04-21 CrT because it is never referenced:
#
# fun wrap_named_recursive_values_list0 (rvbs, per_compile_stuff)
# =
# { my (vars, ndec) = wrap_recdec (rvbs, per_compile_stuff);
#
# case vars
#
# [(_, nv, _)] => (nv, ndec);
# _ => bug "unexpected case in wrapRecursiveValueNamingsList0";
# esac;
# };
# This gets called once locally (below) and once from
#
# src/lib/compiler/front/typer/main/type-core-language.pkg #
fun wrap_named_recursive_values_list (rvbs, per_compile_stuff)
=
{ (wrap_recdec (rvbs, per_compile_stuff))
->
(vars, new_declaration);
fun h ((v, nv, symbol), symbolmapstack)
=
syx::bind (symbol, sxe::NAMED_VARIABLE nv, symbolmapstack);
new_symbolmapstack
=
fold_forward h syx::empty vars;
( new_declaration,
new_symbolmapstack
);
};
arg_var_sym = sy::make_value_symbol "arg";
fun c_markexp (e, r)
=
if (*typer_control::mark_deep_syntax_tree) ds::SOURCE_CODE_REGION_FOR_EXPRESSION (e, r);
else e;
fi;
fun make_deep_syntax_for_mutually_recursive_functions
( complete_match,
named_function_list,
per_compile_stuff as { issue_highcode_codetemp, error_match, ... }: Per_Compile_Stuff
)
=
wrap_named_recursive_values_list (
map named_function_to_named_recursive_values
named_function_list,
per_compile_stuff
)
where
fun named_function_to_named_recursive_values
{ var,
clauses as ( { deep_syntax_patterns, result_typoid, deep_syntax_expression } ! _),
raw_typevars,
source_code_region
}
=>
{ fun getvar _
=
new_valvar (arg_var_sym, issue_highcode_codetemp);
vars = map getvar deep_syntax_patterns;
fun not1 (f,[a]) => a;
not1 (f, l) => f l;
end;
fun do_var valvar
=
ds::VARIABLE_IN_EXPRESSION { var => REF valvar, typescheme_args => [] };
fun do_clause ( { deep_syntax_patterns, deep_syntax_expression, result_typoid=>NULL } )
=>
ds::CASE_RULE (not1 (tuplepat, deep_syntax_patterns), deep_syntax_expression);
do_clause ( { deep_syntax_patterns, deep_syntax_expression, result_typoid=>THE typoid } )
=>
ds::CASE_RULE ( not1 (tuplepat, deep_syntax_patterns),
ds::TYPE_CONSTRAINT_EXPRESSION (deep_syntax_expression, typoid)
);
end;
# -- Matthias says: this seems to generate slightly bogus marks: XXX BUGGO FIXME
#
# mark = case (hd clauses, list::last clauses)
#
# of ( { expression=ds::SOURCE_CODE_REGION_FOR_EXPRESSION(_, (a, _)), ... },
# { expression=ds::SOURCE_CODE_REGION_FOR_EXPRESSION(_, (_, b)), ... }
# )
# =>
# (\\ e => ds::SOURCE_CODE_REGION_FOR_EXPRESSION (e, (a, b)))
#
# | _ => \\ e => e
fun make_expression [var]
=>
ds::FN_EXPRESSION (complete_match (map do_clause clauses), tdt::UNDEFINED_TYPOID);
make_expression vars
=>
fold_backward
( \\ (w, e)
=
ds::FN_EXPRESSION (
complete_match
[ ds::CASE_RULE (ds::VARIABLE_IN_PATTERN w, /*mark*/ e) ],
tdt::UNDEFINED_TYPOID
)
)
( ds::CASE_EXPRESSION (
tupleexp (map do_var vars),
complete_match (map do_clause clauses),
TRUE
)
)
vars;
end;
ds::NAMED_RECURSIVE_VALUE
{
variable => var,
expression => c_markexp (make_expression vars, source_code_region),
raw_typevars,
generalized_typevars => [],
null_or_type => NULL
};
};
named_function_to_named_recursive_values _
=>
bug "make_deep_syntax_for_mutually_recursive_functions";
end;
end; # fun make_deep_syntax_for_mutually_recursive_functions
fun make_handle_expression (
expression,
rules,
per_compile_stuff as { issue_highcode_codetemp, ... }: Per_Compile_Stuff
)
=
{ v = new_valvar (rsj::exception_id, issue_highcode_codetemp);
r = ds::CASE_RULE (ds::VARIABLE_IN_PATTERN v, ds::RAISE_EXPRESSION (ds::VARIABLE_IN_EXPRESSION { var => REF v, typescheme_args => [] }, tdt::UNDEFINED_TYPOID));
rules = complete_match' r rules;
#
ds::EXCEPT_EXPRESSION (expression, (rules, tdt::UNDEFINED_TYPOID));
};
# Transform a raw-syntax var_pattern
# into either a deep-syntax variable
# or a deep-syntax constructor.
#
# If we are given a long path (>1)
# then it has to be a constructor:
#
fun do_var_pattern ( spath,
symbolmapstack,
err,
per_compile_stuff as { issue_highcode_codetemp, ... }: Per_Compile_Stuff
)
=
case spath
#
symbol_path::SYMBOL_PATH [id]
=>
case (fis::find_value_by_symbol (symbolmapstack, id, \\ _ = raise exception syx::UNBOUND))
#
vac::CONSTRUCTOR c
=>
ds::CONSTRUCTOR_PATTERN (c,[]);
_
=>
ds::VARIABLE_IN_PATTERN (new_valvar (id, issue_highcode_codetemp));
esac
except
syx::UNBOUND
=
{ name = symbol::name id;
if (string::has_upper name)
err err::ERROR
( "Undefined constructor: "
+ name
)
err::null_error_body;
fi;
# XXX PLUGH
# print ("src/lib/compiler/front/typer/main/typer-junk.pkg/do_var_pattern: symbol::name(id) = '" + (symbol::name id) + "'\n");
ds::VARIABLE_IN_PATTERN (new_valvar (id, issue_highcode_codetemp));
};
_
=>
ds::CONSTRUCTOR_PATTERN
#
case (fis::find_value_via_symbol_path (symbolmapstack, spath, err))
#
vac::VARIABLE c
=>
{ err err::ERROR
( "variable found where constructor is required: "
+ symbol_path::to_string spath
)
err::null_error_body;
(vac::bogus_valcon, []);
};
vac::CONSTRUCTOR c
=>
(c, []);
esac
except
syx::UNBOUND
=
bug "unbound untrapped";
esac;
fun make_record_pattern (l, is_incomplete, err)
=
ds::RECORD_PATTERN
{
fields => sort_record (l, err),
type_ref => REF tdt::UNDEFINED_TYPOID,
is_incomplete
};
fun clean_pattern
err
(ds::CONSTRUCTOR_PATTERN (tdt::VALCON { is_constant => FALSE, name, ... }, _ ))
=>
{ err
err::ERROR
( "data constructor "
+ sy::name name
+ " used without argument in pattern"
)
err::null_error_body;
ds::WILDCARD_PATTERN;
};
clean_pattern
err
(p as ds::CONSTRUCTOR_PATTERN (tdt::VALCON { is_lazy => TRUE, ... }, _ ))
=>
ds::APPLY_PATTERN (
mtt::dollar_valcon,
[],
p
); # LAZY # second argument = NIL OK?
clean_pattern err p
=>
p;
end;
fun pattern_to_string ds::WILDCARD_PATTERN => "_";
#
pattern_to_string (ds::VARIABLE_IN_PATTERN (vac::PLAIN_VARIABLE { path, ... } )) => syp::to_string path;
pattern_to_string (ds::CONSTRUCTOR_PATTERN (tdt::VALCON { name, ... }, _)) => sy::name name;
pattern_to_string (ds::INT_CONSTANT_IN_PATTERN (i, _)) => multiword_int::to_string i;
pattern_to_string (ds::FLOAT_CONSTANT_IN_PATTERN s) => s;
pattern_to_string (ds::STRING_CONSTANT_IN_PATTERN s) => s;
pattern_to_string (ds::CHAR_CONSTANT_IN_PATTERN s) => "'" + s + "'";
pattern_to_string (ds::RECORD_PATTERN _) => "<record>";
pattern_to_string (ds::APPLY_PATTERN _) => "<application>";
pattern_to_string (ds::TYPE_CONSTRAINT_PATTERN _) => "<constraint pattern>";
pattern_to_string (ds::AS_PATTERN _) => "<layered pattern>";
pattern_to_string (ds::VECTOR_PATTERN _) => "<vector pattern>";
pattern_to_string (ds::OR_PATTERN _) => "<or pattern>";
pattern_to_string _ => "<illegal pattern>";
end;
fun make_apply_pattern err (ds::CONSTRUCTOR_PATTERN (d as tdt::VALCON { is_constant=>FALSE, is_lazy, ... }, t), p)
=>
{ p1 = ds::APPLY_PATTERN (d, t, p);
#
if is_lazy ds::APPLY_PATTERN (mtt::dollar_valcon, [], p1);
else p1;
fi;
};
make_apply_pattern err (ds::CONSTRUCTOR_PATTERN (d as tdt::VALCON { name, ... }, _), _)
=>
{ err
err::ERROR
( "constant constructor applied to argument in pattern:"
+ sy::name name
)
err::null_error_body;
ds::WILDCARD_PATTERN;
};
make_apply_pattern err (operator, _)
=>
{ err
err::ERROR
(
cat [
"non-constructor applied to argument in pattern: ",
pattern_to_string operator
]
)
err::null_error_body;
ds::WILDCARD_PATTERN;
};
end;
fun make_layered_pattern ((x as ds::VARIABLE_IN_PATTERN _), y, _)
=>
ds::AS_PATTERN (x, y);
make_layered_pattern (ds::TYPE_CONSTRAINT_PATTERN (x, t), y, err)
=>
make_layered_pattern (x, ds::TYPE_CONSTRAINT_PATTERN (y, t), err);
make_layered_pattern (x, y, err)
=>
{ err err::ERROR "pattern to left of \"as\" must be variable" err::null_error_body;
y;
};
end;
fun calculate_strictness (arity, body)
=
{ argument_found = rwv::make_rw_vector (arity, FALSE);
fun search (tdt::TYPEVAR_REF { id, ref_typevar => REF (tdt::RESOLVED_TYPEVAR type) } ) => search type;
search (tdt::TYPESCHEME_ARG n) => rwv::set (argument_found, n, TRUE);
#
search (tdt::TYPCON_TYPOID (typ, args)) => apply search args;
search _ => (); # for now...
end;
search body;
rwv::fold_backward (!) NIL argument_found;
};
# Check whether the
# type variables appearing in a type
# (used) are bound (as parameters in
# a type declaration):
#
fun check_bound_typevars (used, bound, err)
=
{ boundset
=
fold_backward
( \\ (v, s)
=
tvs::union (tvs::singleton v, s, err)
)
tvs::empty
bound;
apply nasty (tvs::get_elements (tvs::diff (used, boundset, err)))
where
fun nasty { id => _, ref_typevar => REF (tdt::RESOLVED_TYPEVAR (tdt::TYPEVAR_REF (typevar_ref as { id, ref_typevar }) )) }
=>
nasty typevar_ref;
nasty (typevar_ref as { id => _, ref_typevar => (user_bound as REF (tdt::USER_TYPEVAR _)) })
=>
err
err::ERROR
( "Unbound type variable in type declaration: "
+ ut::typevar_ref_printname typevar_ref
)
err::null_error_body;
nasty _
=>
bug "check_bound_typevars";
end;
end;
};
#
fun symbol_naming_label
( (ds::NUMBERED_LABEL { name, ... }): ds::Numbered_Label
)
: symbol::Symbol
=
name;
exception IS_RECURSIVE;
# Convert a deep syntax ds::NAMED_RECURSIVE_VALUE
# expression to a deep syntax ds::VALUE_DECLARATIONS
# if we can and a deep syntax ds::RECURSIVE_VALUE_DECLARATIONS
# if we must.
#
# This was formerly done in
# src/lib/compiler/back/top/translate/nonrec.pkg;
# but is now done during type checking -- our sole
# call is currently in
# src/lib/compiler/front/typer/types/type-core-language-declaration-g.pkg #
fun convert_deep_syntax_named_recursive_values_list_to_deep_syntax_value_declarations_or_recursive_value_declarations
( rvbs
as
[ ds::NAMED_RECURSIVE_VALUE
{
variable as vac::PLAIN_VARIABLE {
varhome => vh::HIGHCODE_VARIABLE our_root_variable,
...
},
expression,
null_or_type,
raw_typevars,
generalized_typevars
}
]
)
=>
{
{
# If 'expression' contains an internal
# reference to 'our_root_variable'
# from above then we must build
# a RECURSIVE_VALUE_DECLARATIONS
# return value, but otherwise we
# can get away with a simple
# VALUE_DECLARATIONS return value.
#
# Here we recursively dagwalk
# 'expression' searching for appearances
# of our_root_variable. If we find one
# we raise IS_RECURSIVE and exit via the
# below 'except' clause, otherwise we
# return the below VALUE_DECLARATIONS
# expression:
#
check_exp expression;
#
pattern = ds::VARIABLE_IN_PATTERN variable;
expression = case null_or_type
THE type => ds::TYPE_CONSTRAINT_EXPRESSION (expression, type);
NULL => expression;
esac;
#
if (*debugging and ((list::length generalized_typevars) > 0))
printf "Creating NAMED_VALUE from NAMED_RECURSIVE_VALUE with %d-entry generalized_typevars list in \
\convert_deep_syntax_named_recursive_values_list_to_deep_syntax_value_declarations_or_recursive_value_declarations in typer-junk.pkg\n" (list::length generalized_typevars);
printf "\nNAMED_VALUE.generalized_typevars: (%d)\n" (list::length generalized_typevars);
apply unparse_typevar_ref generalized_typevars
where
fun unparse_typevar_ref typevar_ref
=
if_debugging_unparse_typevar_ref ("", typevar_ref);
end;
printf "\n";
if_debugging_unparse_pattern ("\nNAMED_VALUE.pattern == \n", (pattern,100));
if_debugging_unparse_expression ("\nNAMED_VALUE.expression == \n", (expression,100));
if_debugging_prettyprint_pattern ("\nNAMED_VALUE.pattern prettyprint == \n", (pattern, 100));
if_debugging_prettyprint_expression ("\nNAMED_VALUE.expression prettyprint == \n", (expression,100));
fi;
ds::VALUE_DECLARATIONS
[
ds::VALUE_NAMING
{
pattern,
expression,
raw_typevars,
generalized_typevars
}
];
}
except
IS_RECURSIVE = ds::RECURSIVE_VALUE_DECLARATIONS rvbs;
}
where
# All we do here is raise IS_RECURSIVE
# if 'e' anywhere contains 'our_root_variable':
#
fun check_exp e # 'e' == 'exp' == 'expression'
=
case e
#
ds::VARIABLE_IN_EXPRESSION { var => REF (vac::PLAIN_VARIABLE { varhome => vh::HIGHCODE_VARIABLE v, ... } ), ... }
=>
if (v == our_root_variable) raise exception IS_RECURSIVE; fi;
ds::VARIABLE_IN_EXPRESSION _ => ();
ds::RECORD_IN_EXPRESSION l => apply (\\ (lab, x) = check_exp x) l;
ds::SEQUENTIAL_EXPRESSIONS l => apply check_exp l;
ds::APPLY_EXPRESSION { operator, operand } => { check_exp operator; check_exp operand;};
ds::TYPE_CONSTRAINT_EXPRESSION (x, _) => check_exp x;
ds::EXCEPT_EXPRESSION (x, (l, _)) => { check_exp x; apply (\\ ds::CASE_RULE (_, x) = check_exp x) l;};
ds::RAISE_EXPRESSION (x, _) => check_exp x;
ds::LET_EXPRESSION (d, x) => { check_dec d; check_exp x;};
ds::CASE_EXPRESSION (x, l, _) => { check_exp x; apply (\\ ds::CASE_RULE (_, x) = check_exp x) l; };
ds::IF_EXPRESSION { test_case, then_case, else_case }
=>
{ check_exp test_case;
check_exp then_case;
check_exp else_case;
};
( ds::AND_EXPRESSION (e1, e2)
| ds::OR_EXPRESSION (e1, e2)
| ds::WHILE_EXPRESSION { test => e1, expression => e2 }
)
=>
{ check_exp e1;
check_exp e2;
};
ds::FN_EXPRESSION (l, _) => apply (\\ ds::CASE_RULE (_, x) = check_exp x) l;
ds::SOURCE_CODE_REGION_FOR_EXPRESSION (x, _) => check_exp x;
ds::RECORD_SELECTOR_EXPRESSION (_, e) => check_exp e;
ds::VECTOR_IN_EXPRESSION (el, _) => apply check_exp el;
ds::ABSTRACTION_PACKING_EXPRESSION (e, _, _) => check_exp e;
( ds::VALCON_IN_EXPRESSION _
| ds::INT_CONSTANT_IN_EXPRESSION _
| ds::UNT_CONSTANT_IN_EXPRESSION _
| ds::FLOAT_CONSTANT_IN_EXPRESSION _
| ds::STRING_CONSTANT_IN_EXPRESSION _
| ds::CHAR_CONSTANT_IN_EXPRESSION _
)
=> ();
esac
# All we do here is raise IS_RECURSIVE
# if 'd' anywhere contains 'our_root_variable':
#
also
fun check_dec d # 'd' == 'dec' == 'declaration'
=
case d
#
ds::VALUE_DECLARATIONS vbl => apply (\\ (ds::VALUE_NAMING { expression, ... } ) = check_exp expression) vbl;
ds::RECURSIVE_VALUE_DECLARATIONS rvbl => apply (\\ (ds::NAMED_RECURSIVE_VALUE { expression, ... } ) = check_exp expression) rvbl;
ds::LOCAL_DECLARATIONS (a, b) => { check_dec a; check_dec b;};
#
ds::SEQUENTIAL_DECLARATIONS l => apply check_dec l;
ds::SOURCE_CODE_REGION_FOR_DECLARATION (declaration, _) => check_dec declaration;
_ => ();
esac;
end;
convert_deep_syntax_named_recursive_values_list_to_deep_syntax_value_declarations_or_recursive_value_declarations
rvbs
=>
ds::RECURSIVE_VALUE_DECLARATIONS rvbs;
end;
# contains_package_declaration() tests whether there are
# explicit package declarations in a declaration.
#
# This is used in type_package_language when
# typechecking LOCAL_DECLARATIONS, as a cheap approximate
# check of whether a declaration contains any
# generic declarations.
#
fun contains_package_declaration (raw::PACKAGE_DECLARATIONS _) => TRUE;
contains_package_declaration (raw::GENERIC_DECLARATIONS _) => TRUE;
contains_package_declaration (raw::LOCAL_DECLARATIONS (dec_in, dec_out))
=>
contains_package_declaration dec_in or
contains_package_declaration dec_out;
contains_package_declaration (raw::SEQUENTIAL_DECLARATIONS decs)
=>
list::exists contains_package_declaration decs;
contains_package_declaration (raw::SOURCE_CODE_REGION_FOR_DECLARATION (declaration, _))
=>
contains_package_declaration declaration;
contains_package_declaration _ => FALSE;
end;
}; # package typer_junk
end; # stipulate