PreviousUpNext

15.4.651  src/lib/compiler/front/typer/main/validate-message-type.pkg

## 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;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext