## validate-message-type.pkg
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib# Our current OOP implementation places a number of
# restrictions on message types:
#
# o They must be arrow (function) types, obviously.
# o The first argument must be of type Self(X)
# o The only type variable allowed in the type is X.
#
# Violating any these restrictions will produce an error
# message eventually, but since it will be in synthesized
# (thus invisible) code with no very accurate or useful
# source_code_region, it will in general be pretty
# mysterious, so here we check those restrictions explicitly
# up-front where we can issue an accurate and to the point
# compiler diagnostic for the user.
stipulate
package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package lnd = line_number_db; # line_number_db is from src/lib/compiler/front/basics/source/line-number-db.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package ppr = prettyprint_raw_syntax; # prettyprint_raw_syntax is from src/lib/compiler/front/typer/print/prettyprint-raw-syntax.pkg package raw = raw_syntax; # raw_syntax is from src/lib/compiler/front/parser/raw-syntax/raw-syntax.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package tyc = typer_control; # typer_control is from src/lib/compiler/front/typer/basics/typer-control.pkg package tys = typer_junk; # typer_junk is from src/lib/compiler/front/typer/main/typer-junk.pkg package urs = unparse_raw_syntax; # unparse_raw_syntax is from src/lib/compiler/front/typer/print/unparse-raw-syntax.pkg Pp = pp::Pp;
herein
package validate_message_type
: Validate_Message_Type # Validate_Message_Type is from src/lib/compiler/front/typer/main/validate-message-type.api {
debugging = tyc::expand_oop_syntax_debugging; # eval: set_control "typechecker::expand_oop_syntax_debugging" "TRUE";
fun unparse_type
(
msg: String,
type: raw::Any_Type,
symbolmapstack: syx::Symbolmapstack
)
=
{
# if *debugging
print "\n";
print msg;
pp = pp::make_standard_prettyprinter_into_file "/dev/stdout" [];
urs::unparse_type
(symbolmapstack, NULL)
pp
(type, 100);
pp.flush ();
pp.close ();
print "\n";
# fi;
};
fun prettyprint_type
(
msg: String,
type: raw::Any_Type,
symbolmapstack: syx::Symbolmapstack
)
=
{
# if *debugging
print "\n";
print msg;
pp = pp::make_standard_prettyprinter_into_file "/dev/stdout" [];
ppr::prettyprint_type
(symbolmapstack, NULL)
pp
(type, 100);
pp.flush ();
pp.close ();
print "\n";
# fi;
};
arrow_symbol = sy::make_type_symbol "->";
self_symbol = sy::make_type_symbol "Self";
type_x_symbol = sy::make_typevar_symbol "X";
fun validate_message_type
( type: raw::Any_Type,
symbolmapstack: syx::Symbolmapstack,
source_code_region: lnd::Source_Code_Region,
per_compile_stuff as
{
error_fn,
...
}: tys::Per_Compile_Stuff,
syntax_error_count: Int
)
:
Int # Updated syntax_errors count.
=
{
# Verify that type looks like
#
# Self(X) -> ...
#
verify_type_is_selfx_arrow (type, source_code_region);
# Verify that only type variable used is X:
#
verify_x_is_only_typevar (type, source_code_region);
*syntax_errors;
}
where
syntax_errors = REF syntax_error_count;
fun gripe tag
=
{ syntax_errors := *syntax_errors + 1;
error_fn
source_code_region
err::ERROR
(sprintf "%s: message fun type must be 'Self(X) -> ...'" tag)
err::null_error_body;
};
# Verify that type is
#
# Self(X)
#
fun verify_type_is_selfx (raw::SOURCE_CODE_REGION_FOR_TYPE (type, source_code_region), _)
=>
verify_type_is_selfx (type, source_code_region);
verify_type_is_selfx (raw::TYPE_TYPE ([ constructor_name ], [ type ]), source_code_region)
=>
{
if (sy::eq (constructor_name, self_symbol))
();
else
gripe "www";
fi;
} ;
verify_type_is_selfx _
=>
gripe "xxx";
end;
# Verify that type looks like
#
# Self(X) -> ...
#
fun verify_type_is_selfx_arrow (raw::SOURCE_CODE_REGION_FOR_TYPE (type, source_code_region), _)
=>
verify_type_is_selfx_arrow (type, source_code_region);
verify_type_is_selfx_arrow (raw::TYPE_TYPE ([ constructor_name ], [ from_type, to_type ]), source_code_region)
=>
# Start by checking that we have
# an arrow type:
#
if (sy::eq (constructor_name, arrow_symbol))
verify_type_is_selfx (from_type, source_code_region);
# unparse_type ("bbb case unparsing from_type:", from_type, symbolmapstack);
# prettyprint_type ("bbb case prettyprinting from_type:", from_type, symbolmapstack);
else
gripe "ccc";
fi;
verify_type_is_selfx_arrow _
=>
# XXX BUGGO FIXME gripe should be passed current source_code_region!!!
gripe "ddd";
end;
# Verify that a typevar is 'X':
#
fun verify_typevar_is_x (raw::SOURCE_CODE_REGION_FOR_TYPEVAR (typevar, source_code_region), _)
=>
verify_typevar_is_x (typevar, source_code_region);
verify_typevar_is_x (raw::TYPEVAR typevar_symbol, source_code_region)
=>
if (not (sy::eq (typevar_symbol, type_x_symbol)))
syntax_errors := *syntax_errors + 1;
error_fn
source_code_region
err::ERROR
(sprintf "Disallowed type variable name '%s' (only type variable allowed in message type is 'X'))" (sy::name typevar_symbol))
err::null_error_body;
fi;
end;
# Verify that X is only type variable used in type:
#
fun verify_x_is_only_typevar (raw::TYPEVAR_TYPE typevar, _)
=>
verify_typevar_is_x (typevar, source_code_region);
verify_x_is_only_typevar (raw::SOURCE_CODE_REGION_FOR_TYPE (type, source_code_region), _)
=>
verify_x_is_only_typevar (type, source_code_region);
verify_x_is_only_typevar (raw::TYPE_TYPE (symbols, types), source_code_region)
=>
apply (\\ type = verify_x_is_only_typevar (type, source_code_region))
types;
verify_x_is_only_typevar (raw::TUPLE_TYPE types, source_code_region)
=>
apply (\\ type = verify_x_is_only_typevar (type, source_code_region))
types;
verify_x_is_only_typevar (raw::RECORD_TYPE pairs, source_code_region)
=>
apply (\\ (symbol, type) = verify_x_is_only_typevar (type, source_code_region))
pairs;
end;
end;
};
end;