## 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 ty = types; # types is from src/lib/compiler/front/typer-stuff/types/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 -> ty::Type;
}
{
fun bug msg
=
error_message::impossible("Reconstruct: " + msg);
infix my --> ;
fun reduce_type (ty::TYPE_SCHEME_TYPE { type_scheme => ty::TYPE_SCHEME { body, arity }, ... } )
=>
tyj::head_reduce_type body;
reduce_type type
=>
tyj::head_reduce_type type;
end;
fun reconstruct_expression_type (ds::VARIABLE_IN_EXPRESSION (REF (vac::ORDINARY_VARIABLE { var_type => REF type, ... } ), insttys))
=>
case type
#
ty::TYPE_SCHEME_TYPE { type_scheme, ... } => tyj::apply_type_scheme (type_scheme, insttys);
_ => type;
esac;
reconstruct_expression_type (ds::VARIABLE_IN_EXPRESSION _)
=>
bug "varexp";
reconstruct_expression_type (ds::VALCON_IN_EXPRESSION (ty::VALCON { type, ... }, insttys))
=>
case type
#
ty::TYPE_SCHEME_TYPE { type_scheme, ... } => tyj::apply_type_scheme (type_scheme, insttys);
_ => type;
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_type;
reconstruct_expression_type (ds::CHAR_CONSTANT_IN_EXPRESSION _) => ctt::char_type;
reconstruct_expression_type (ds::FLOAT_CONSTANT_IN_EXPRESSION _) => ctt::float64_type;
reconstruct_expression_type (ds::RECORD_IN_EXPRESSION fields)
=>
{ fun extract (ds::NUMBERED_LABEL { name, ... }, expression)
=
(name, reconstruct_expression_type expression);
ctt::record_type (map extract (tyj::sort_fields fields));
};
reconstruct_expression_type (ds::VECTOR_IN_EXPRESSION (NIL, vty)) => ty::TYPCON_TYPE (ctt::vector_typ,[vty]);
reconstruct_expression_type (ds::VECTOR_IN_EXPRESSION((a ! _), vty)) => ty::TYPCON_TYPE (ctt::vector_typ,[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_type (reconstruct_expression_type operator))
#
ty::TYPCON_TYPE(_,[_, t]) => t;
#
ty::TYPE_SCHEME_TYPE _ => bug "poly-operator";
ty::WILDCARD_TYPE => bug "wildcard-operator";
ty::UNDEFINED_TYPE => bug "undef-operator";
ty::TYPE_SCHEME_ARG_I _ => bug "ibound-operator";
ty::TYPE_VARIABLE_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-2013,
## released per terms of SMLNJ-COPYRIGHT.