## reconstruct-expression-type.pkg
#
# Support for:
#
# src/lib/compiler/debugging-and-profiling/profiling/tdp-instrument.pkg# src/lib/compiler/debugging-and-profiling/profiling/add-per-fun-call-counters-to-deep-syntax.pkg# Compiled by:
# src/lib/compiler/debugging-and-profiling/debugprof.sublib### "1545 Relay #70 Panel F (moth) in relay.
### First actual case of bug being found."
###
### -- Harvard Mark II logbook, 1947
stipulate
package ctt = core_type_types; # core_type_types is from src/lib/compiler/front/typer-stuff/types/core-type-types.pkg package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package tyj = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package vac = variables_and_constructors; # variables_and_constructors is from src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg #
--> = ctt::(-->) ;
herein
package reconstruct_expression_type
: (weak)
api {
reconstruct_expression_type: ds::Deep_Expression -> tdt::Typoid;
}
{
fun bug msg
=
error_message::impossible("Reconstruct: " + msg);
infix my --> ;
fun reduce_typoid (tdt::TYPESCHEME_TYPOID { typescheme => tdt::TYPESCHEME { body, arity }, ... } )
=>
tyj::head_reduce_typoid body;
reduce_typoid typoid
=>
tyj::head_reduce_typoid typoid;
end;
fun reconstruct_expression_type (ds::VARIABLE_IN_EXPRESSION { var => REF (vac::PLAIN_VARIABLE { vartypoid_ref => REF type, ... } ), typescheme_args })
=>
case type
#
tdt::TYPESCHEME_TYPOID { typescheme, ... } => tyj::apply_typescheme (typescheme, typescheme_args);
_ => type;
esac;
reconstruct_expression_type (ds::VARIABLE_IN_EXPRESSION _)
=>
bug "varexp";
reconstruct_expression_type (ds::VALCON_IN_EXPRESSION { valcon => tdt::VALCON { typoid, ... }, typescheme_args })
=>
case typoid
#
tdt::TYPESCHEME_TYPOID { typescheme, ... } => tyj::apply_typescheme (typescheme, typescheme_args);
_ => typoid;
esac;
reconstruct_expression_type (ds::INT_CONSTANT_IN_EXPRESSION (_, t)) => t;
reconstruct_expression_type (ds::UNT_CONSTANT_IN_EXPRESSION (_, t)) => t;
reconstruct_expression_type (ds::STRING_CONSTANT_IN_EXPRESSION _) => ctt::string_typoid;
reconstruct_expression_type (ds::CHAR_CONSTANT_IN_EXPRESSION _) => ctt::char_typoid;
reconstruct_expression_type (ds::FLOAT_CONSTANT_IN_EXPRESSION _) => ctt::float64_typoid;
reconstruct_expression_type (ds::RECORD_IN_EXPRESSION fields)
=>
{ fun extract (ds::NUMBERED_LABEL { name, ... }, expression)
=
(name, reconstruct_expression_type expression);
ctt::record_typoid (map extract (tyj::sort_fields fields));
};
reconstruct_expression_type (ds::VECTOR_IN_EXPRESSION (NIL, vty)) => tdt::TYPCON_TYPOID (ctt::ro_vector_type,[vty]);
reconstruct_expression_type (ds::VECTOR_IN_EXPRESSION((a ! _), vty)) => tdt::TYPCON_TYPOID (ctt::ro_vector_type,[vty]);
reconstruct_expression_type (ds::ABSTRACTION_PACKING_EXPRESSION (e, t, _)) => t;
reconstruct_expression_type (ds::SEQUENTIAL_EXPRESSIONS [a]) => reconstruct_expression_type a;
reconstruct_expression_type (ds::SEQUENTIAL_EXPRESSIONS (_ ! rest)) => reconstruct_expression_type (ds::SEQUENTIAL_EXPRESSIONS rest);
reconstruct_expression_type (ds::APPLY_EXPRESSION { operator, operand })
=>
case (reduce_typoid (reconstruct_expression_type operator))
#
tdt::TYPCON_TYPOID(_,[_, t]) => t;
#
tdt::TYPESCHEME_TYPOID _ => bug "poly-operator";
tdt::WILDCARD_TYPOID => bug "wildcard-operator";
tdt::UNDEFINED_TYPOID => bug "undef-operator";
tdt::TYPESCHEME_ARG _ => bug "ibound-operator";
tdt::TYPEVAR_REF _ => bug "varty-operator";
_ => bug "operator";
esac;
reconstruct_expression_type (ds::TYPE_CONSTRAINT_EXPRESSION (e, type)) => reconstruct_expression_type e;
reconstruct_expression_type (ds::EXCEPT_EXPRESSION (e, h)) => reconstruct_expression_type e;
reconstruct_expression_type (ds::RAISE_EXPRESSION (e, t)) => t;
reconstruct_expression_type (ds::LET_EXPRESSION(_, e)) => reconstruct_expression_type e;
reconstruct_expression_type (ds::CASE_EXPRESSION(_, ds::CASE_RULE(_, e) ! _, _)) => reconstruct_expression_type e;
reconstruct_expression_type (ds::FN_EXPRESSION (ds::CASE_RULE(_, e) ! _, type)) => type --> reconstruct_expression_type e;
reconstruct_expression_type (ds::SOURCE_CODE_REGION_FOR_EXPRESSION (e, _)) => reconstruct_expression_type e;
reconstruct_expression_type _ => bug "reconstruct_expression_type";
end;
}; # package reconstruct_expression_type
end;
## COPYRIGHT (c) 1996 AT&T Bell Laboratories
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.