PreviousUpNext

15.4.640  src/lib/compiler/front/typer/main/oop-rewrite-declaration.pkg

## oop-rewrite-declaration.pkg

# Compiled by:
#     src/lib/compiler/front/typer/typer.sublib

# Mythryl classes are lightly modified packages.
# To expand oop constructs into the vanilla non-OOP
# underlying language we must traverse the class
# (package) syntax tree converting everything oop
# into vanilla non-oop form.
#
# In this package we implement the package syntax
# tree dagwalk subtask.  This involves a set of
# mutually recursive functions mirroring the
# mutually recursive grammar rules defining package
# syntax:


stipulate
    package err =  error_message;                               # error_message                 is from   src/lib/compiler/front/basics/errormsg/error-message.pkg
    package eos =  expand_oop_syntax_junk;                      # expand_oop_syntax_junk        is from   src/lib/compiler/front/typer/main/expand-oop-syntax-junk.pkg
    package mld =  module_level_declarations;                   # module_level_declarations     is from   src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg
    package raw =  raw_syntax;                                  # raw_syntax                    is from   src/lib/compiler/front/parser/raw-syntax/raw-syntax.pkg


    include fast_symbol;                                        # fast_symbol                   is from   src/lib/compiler/front/basics/map/fast-symbol.pkg
    include raw_syntax;                                         # raw_syntax                    is from   src/lib/compiler/front/parser/raw-syntax/raw-syntax.pkg
    include raw_syntax_junk;                                    # raw_syntax_junk               is from   src/lib/compiler/front/parser/raw-syntax/raw-syntax-junk.pkg
herein

    package oop_rewrite_declaration
    :       Oop_Rewrite_Declaration                             # Oop_Rewrite_Declaration       is from   src/lib/compiler/front/typer/main/oop-rewrite-declaration.api
    {

        # We get called from
        #     src/lib/compiler/front/typer/main/expand-oop-syntax.pkg
        # to rewrite the raw syntax tree
        # for a class.
        #
        # Our tasks are:
        #   o Remove all 'field my   ... ' declarations.
        #   o Remove all 'message fun ... ' declarations.
        #   o Remove all 'method fun  ... ' declarations.
        #   o Replace the first of the removed statements
        #     with the blob of synthesized code implementing
        #     all the oop stuff.
        #   o Rewrite object->field syntax into vanilla code.
        #     this requires us to traverse the full expression
        #     syntax.
        #
        # We return the rewritten raw syntax tree.
        #
        fun rewrite_declaration
            { original_declaration:  raw_syntax::Declaration,
              synthesized_code:      raw_syntax::Declaration,
              field_to_offset:       symbol::Symbol -> Int
            }
            =
            {
                rewritten_synthesized_code = REF synthesized_code;
                inserted_synthesized_code  = REF FALSE;

                fun do_package_expression_bool (package_expression, bool)
                    =
                    ( do_package_expression  package_expression,
                      bool
                    )

                also
                fun do_package_expression_bools (pb ! more, result)
                        =>
                        do_package_expression_bools (more,  do_package_expression_bool pb ! result);

                    do_package_expression_bools ([], result)
                        =>
                        reverse result;
                end

                also
                fun do_package_expression  package_expression
                    =
                    case package_expression

                    PACKAGE_DEFINITION  declaration
                        =>
                        PACKAGE_DEFINITION (do_the_declaration  declaration);

                    CALL_OF_GENERIC          (path,   package_expression_bool_list)
                        =>
                        CALL_OF_GENERIC
                            ( path,
                              do_package_expression_bools (package_expression_bool_list, [])
                            );

                    INTERNAL_CALL_OF_GENERIC          (path,   package_expression_bool_list)
                        =>
                        INTERNAL_CALL_OF_GENERIC
                            ( path,
                              do_package_expression_bools (package_expression_bool_list, [])
                            );

                    LET_IN_PACKAGE (declaration,   package_expression)
                        =>
                        LET_IN_PACKAGE (
                            do_the_declaration     declaration,
                            do_package_expression  package_expression
                        );

                    PACKAGE_CAST (    package_expression, api_expression)
                        =>
                        PACKAGE_CAST (
                            do_package_expression  package_expression,
                            api_expression
                        );

                    SOURCE_CODE_REGION_FOR_PACKAGE( package_expression, region)
                        =>
                        SOURCE_CODE_REGION_FOR_PACKAGE(
                            do_package_expression  package_expression,
                            region
                        );

                    PACKAGE_BY_NAME path
                        =>
                        package_expression;

                    esac

                also
                fun do_package_expressions ([], result)
                        =>
                        reverse result;

                    do_package_expressions (package_expression ! rest, result)
                        =>
                        do_package_expressions (rest, (do_package_expression package_expression) ! result);
                end

                also
                fun do_named_package (me as NAMED_PACKAGE { name_symbol, definition => package_expression, constraint, kind })
                        =>
                        NAMED_PACKAGE
                            { name_symbol,
                              definition =>  do_package_expression  package_expression,
                              constraint,
                              kind
                            };

                    do_named_package (SOURCE_CODE_REGION_FOR_NAMED_PACKAGE  (named_package, region))
                        =>
                        SOURCE_CODE_REGION_FOR_NAMED_PACKAGE
                            ( do_named_package  named_package,
                              region
                            );
                end

                also
                fun do_named_packages ([], result)
                        =>
                        reverse result;

                    do_named_packages (named_package ! rest, result)
                        =>
                        do_named_packages (rest, (do_named_package named_package) ! result);
                end

                also
                fun do_generic_expression  (generic_expression as GENERIC_BY_NAME _)
                        =>
                        generic_expression;

                    do_generic_expression  (LET_IN_GENERIC  (declaration,  generic_expression))
                        =>
                        LET_IN_GENERIC  (
                            do_the_declaration     declaration,
                            do_generic_expression  generic_expression
                        );

                    do_generic_expression (GENERIC_DEFINITION  { parameters, body => package_expression, constraint })
                        =>
                        GENERIC_DEFINITION
                            { parameters,
                              body =>   do_package_expression  package_expression,
                              constraint
                            };

                    do_generic_expression  (CONSTRAINED_CALL_OF_GENERIC ( path, package_expression_bools, api_constraint ) )
                        =>
                        CONSTRAINED_CALL_OF_GENERIC
                            ( path,
                              do_package_expression_bools  (package_expression_bools, []),
                              api_constraint
                            );

                    do_generic_expression  (SOURCE_CODE_REGION_FOR_GENERIC  (generic_expression, region))
                        =>
                        SOURCE_CODE_REGION_FOR_GENERIC
                            ( do_generic_expression  generic_expression,
                              region
                            );
                end


                also
                fun do_named_generics  ([],  result)
                        =>
                        reverse result;

                    do_named_generics  (named_generic ! named_generics,  result)
                        =>
                        do_named_generics  (named_generics,  (do_named_generic named_generic) ! result)
                        where
                            fun do_named_generic  (NAMED_GENERIC  {  name_symbol,  definition => generic_expression })
                                    =>
                                    NAMED_GENERIC  {
                                        name_symbol,
                                        definition =>  do_generic_expression  generic_expression
                                    };

                                do_named_generic (SOURCE_CODE_REGION_FOR_NAMED_GENERIC  (named_generic,  region))
                                    =>
                                    SOURCE_CODE_REGION_FOR_NAMED_GENERIC
                                      ( do_named_generic  named_generic,
                                        region
                                      );
                            end;
                        end;
                end

                also
                fun do_pattern_clause (PATTERN_CLAUSE { patterns, result_type, expression })
                    =
                    PATTERN_CLAUSE
                      { patterns,
                        result_type,
                        expression =>  do_raw_expression  expression
                      }

                also
                fun do_pattern_clauses  ([],  result)
                        =>
                        reverse result;

                    do_pattern_clauses  (pattern_clause ! rest,  result)
                        =>
                        do_pattern_clauses (rest, (do_pattern_clause  pattern_clause) ! result);
                end


                also
                fun do_named_function  (f as (NAMED_FUNCTION { pattern_clauses, is_lazy, kind, null_or_type }))
                        =>
                        {   f = NAMED_FUNCTION
                                  { pattern_clauses =>  do_pattern_clauses (pattern_clauses, []),
                                    is_lazy,
                                    kind,
                                    null_or_type
                                  };

                            # We return   NULL   to tell caller to remove function from syntax tree.
                            # We return   THE f  to tell it to leave it in place:
                            #
                            case (kind, null_or_type)
                                 (MESSAGE_FUN, THE type) =>  { NULL; };
                                 (METHOD_FUN,  NULL    ) =>  { NULL; };
                                 (PLAIN_FUN,   NULL    ) =>  THE f;
                                 _                       =>   raise exception FAIL "expand-oop-syntax.pkg (NAMED_FUNCTION): Impossible";        # XXX SUCKO FIXME what's the correct error protocol?
                            esac;

                        };

                    do_named_function (SOURCE_CODE_REGION_FOR_NAMED_FUNCTION  (named_function, region))
                        =>
                        case  (do_named_function  named_function)
                            THE f   =>  THE (SOURCE_CODE_REGION_FOR_NAMED_FUNCTION  (f, region));       # Returning normal function.
                            NULL    =>  NULL;                                                   # Erasing method from syntax tree.
                        esac;
                end

                also
                fun do_named_functions  ([],  result)
                        =>
                        reverse result;

                    do_named_functions  (named_function ! rest,  result)
                        =>
                        case  (do_named_function  named_function)
                            THE f   =>  do_named_functions  (rest,  f ! result);                        # It was a function, leave it in syntax tree.
                            NULL    =>  do_named_functions  (rest,      result);                        # It was a method, erase it from syntax tree.
                        esac;
                end

                also
                fun do_named_recursive_value  (NAMED_RECURSIVE_VALUE { variable_symbol, fixity, expression, null_or_type, is_lazy })
                        =>
                        NAMED_RECURSIVE_VALUE
                          { variable_symbol,
                            fixity,
                            expression  => do_raw_expression  expression,
                            null_or_type,
                            is_lazy
                          };

                    do_named_recursive_value  (SOURCE_CODE_REGION_FOR_RECURSIVELY_NAMED_VALUE (named_recursive_value, region))
                        =>
                        SOURCE_CODE_REGION_FOR_RECURSIVELY_NAMED_VALUE (do_named_recursive_value named_recursive_value, region);
                end

                also
                fun do_named_recursive_values  ([],  result)
                        =>
                        reverse result;

                    do_named_recursive_values  (named_recursive_value ! rest,  result)
                        =>
                        do_named_recursive_values  (rest,  (do_named_recursive_value  named_recursive_value) ! result);
                end

                also
                fun do_case_rules ([], result)
                        =>
                        reverse result;

                    do_case_rules ((CASE_RULE { pattern, expression }) ! rest, result)
                        =>
                        do_case_rules (rest, (CASE_RULE { pattern, expression => do_raw_expression  expression }) ! result);
                end

                also
                fun do_raw_expression_fixity_item { item, fixity, source_code_region }
                        =
                        {  item => do_raw_expression  item,
                           fixity,
                           source_code_region
                        }

                also
                fun do_raw_expression_fixity_items ([], result)
                        =>
                        reverse result;

                    do_raw_expression_fixity_items (item ! rest, result)
                        =>
                        do_raw_expression_fixity_items (rest, (do_raw_expression_fixity_item  item) ! result);
                end

                also
                fun do_record_expression_entries ([], result)
                        =>
                        reverse result;

                    do_record_expression_entries ((symbol, expression) ! rest, result)
                        =>
                        do_record_expression_entries (rest, (symbol, do_raw_expression expression) ! result);
                end

                also
                fun do_object_field_expression { object, field }
                    =
                    {
                        # We map 'a->b' to be '#3 (get__fields a)'
                        # if 'b' is the third field in the (sub)object:

                        # Make symbol naming 'get__fields' function:
                        #
                        get_fields_symbol
                            =
                            make_value_symbol( raw_symbol( get_fields_hash, get_fields_string ) );

                        # Set selector_num to 3 if our field
                        # is third in (sub)object:
                        #
                        selector_num
                            =
                            (field_to_offset field) + 1;        # '+1' because offsets start at 0 but #1 is first field.

                        # Make (#3 (get__fields object)) or such:
                        #
                        APPLY_EXPRESSION
                          {
                            function => RECORD_SELECTOR_EXPRESSION (symbol::make_label_symbol (int::to_string selector_num)),
                            argument => APPLY_EXPRESSION
                                          {
                                            function => VARIABLE_IN_EXPRESSION [ get_fields_symbol ],
                                            argument => object
                                          }
                          };
                    }

                also
                fun do_raw_expression (v as (VARIABLE_IN_EXPRESSION        _))  =>  v;
                    do_raw_expression (p as (IMPLICIT_THUNK_PARAMETER      _))  =>  p;
                    do_raw_expression (i as (INT_CONSTANT_IN_EXPRESSION    _))  =>  i;
                    do_raw_expression (u as (UNT_CONSTANT_IN_EXPRESSION    _))  =>  u;
                    do_raw_expression (f as (FLOAT_CONSTANT_IN_EXPRESSION  _))  =>  f;
                    do_raw_expression (s as (STRING_CONSTANT_IN_EXPRESSION _))  =>  s;
                    do_raw_expression (c as (CHAR_CONSTANT_IN_EXPRESSION   _))  =>  c;
                    do_raw_expression (r as (RECORD_SELECTOR_EXPRESSION    _))  =>  r;

                    do_raw_expression (SEQUENCE_EXPRESSION expressions) =>  SEQUENCE_EXPRESSION (do_raw_expressions (expressions, []));
                    do_raw_expression (LIST_EXPRESSION     expressions) =>  LIST_EXPRESSION     (do_raw_expressions (expressions, []));
                    do_raw_expression (TUPLE_EXPRESSION    expressions) =>  TUPLE_EXPRESSION    (do_raw_expressions (expressions, []));
                    do_raw_expression (VECTOR_IN_EXPRESSION   expressions) =>  VECTOR_IN_EXPRESSION   (do_raw_expressions (expressions, []));

                    do_raw_expression (FN_EXPRESSION case_rules)
                        =>
                        FN_EXPRESSION (do_case_rules (case_rules, []));

                    do_raw_expression (CASE_EXPRESSION { expression, rules })
                        =>
                        CASE_EXPRESSION
                          { expression => do_raw_expression  expression,
                            rules      => do_case_rules     (rules, [])
                          }; 

                    do_raw_expression (EXCEPT_EXPRESSION { expression, rules })
                        =>
                        EXCEPT_EXPRESSION
                          { expression => do_raw_expression  expression,
                            rules      => do_case_rules     (rules, [])
                          }; 

                    do_raw_expression (PRE_FIXITY_EXPRESSION fixity_items)
                        =>
                        PRE_FIXITY_EXPRESSION (do_raw_expression_fixity_items  (fixity_items, []));

                    do_raw_expression (RAISE_EXPRESSION expression)
                        =>
                        RAISE_EXPRESSION (do_raw_expression  expression);

                    do_raw_expression (APPLY_EXPRESSION { function, argument })
                        =>
                        APPLY_EXPRESSION
                          {  function =>  do_raw_expression  function,
                             argument =>  do_raw_expression  argument
                          };

                    do_raw_expression (OBJECT_FIELD_EXPRESSION object_field)
                        =>
                        do_object_field_expression  object_field;

                    do_raw_expression (AND_EXPRESSION (expression1, expression2))
                        =>
                        AND_EXPRESSION
                          ( do_raw_expression  expression1,
                            do_raw_expression  expression2
                          );

                    do_raw_expression (OR_EXPRESSION (expression1, expression2))
                        =>
                        OR_EXPRESSION
                          ( do_raw_expression  expression1,
                            do_raw_expression  expression2
                          );

                    do_raw_expression (WHILE_EXPRESSION { test, expression })
                        =>
                        WHILE_EXPRESSION
                          { test       =>  do_raw_expression  test,
                            expression =>  do_raw_expression  expression
                          };

                    do_raw_expression (IF_EXPRESSION { test_case, then_case, else_case })
                        =>
                        IF_EXPRESSION
                          { test_case  =>  do_raw_expression  test_case,
                            then_case  =>  do_raw_expression  then_case,
                            else_case  =>  do_raw_expression  else_case
                          };

                    do_raw_expression (LET_EXPRESSION { declaration, expression })
                        =>
                        LET_EXPRESSION
                          { declaration =>  do_the_declaration   declaration,
                            expression  =>  do_raw_expression    expression
                          }; 

                    do_raw_expression (TYPE_CONSTRAINT_EXPRESSION { expression, constraint })
                        =>
                        TYPE_CONSTRAINT_EXPRESSION
                          { expression =>  do_raw_expression  expression,
                            constraint
                          }; 

                    do_raw_expression (RECORD_IN_EXPRESSION record_expression_entries)
                        =>
                        RECORD_IN_EXPRESSION (do_record_expression_entries (record_expression_entries, []));

                    do_raw_expression (SOURCE_CODE_REGION_FOR_EXPRESSION (expression, region))
                        =>
                        SOURCE_CODE_REGION_FOR_EXPRESSION (do_raw_expression expression, region);
                end

                also
                fun do_raw_expressions ([], result)
                        =>
                        reverse result;

                    do_raw_expressions  (expression ! rest,  result)
                        =>
                        do_raw_expressions (rest,  (do_raw_expression expression) ! result);
                end

                also
                fun do_named_value  (NAMED_VALUE { pattern, expression, is_lazy })
                        =>
                        NAMED_VALUE
                          { pattern,                                                            # We do not (yet?) rewrite Case_Patterns
                            expression => do_raw_expression expression,
                            is_lazy
                          };

                    do_named_value (SOURCE_CODE_REGION_FOR_NAMED_VALUE  (named_value, region))
                        =>
                        SOURCE_CODE_REGION_FOR_NAMED_VALUE
                          (  do_named_value  named_value,
                             region
                          );
                end

                also
                fun do_named_values  ([],  result)
                        =>
                        reverse result;

                    do_named_values  (named_value ! rest,  result)
                        =>
                        do_named_values (rest,  (do_named_value named_value) ! result);
                end


                also
                fun do_the_declaration  declaration
                    =
                    the (do_declaration declaration)

                also
                fun do_named_field  (NAMED_FIELD { name, type, init })
                        =>
                        NAMED_FIELD
                          { name,
                            type,
                            init  =>  case init
                                          NULL           =>  NULL;
                                          THE expression =>  THE (do_raw_expression  expression);
                                      esac
                          };

                    do_named_field (SOURCE_CODE_REGION_FOR_NAMED_FIELD  (named_field, region))
                        =>
                        SOURCE_CODE_REGION_FOR_NAMED_FIELD
                          (  do_named_field  named_field,
                             region
                          );
                end

                also
                fun do_named_fields ([], result)
                        =>
                        reverse result;

                    do_named_fields (named_field ! rest, result)
                        =>
                        do_named_fields (rest, (do_named_field ! result));
                end


                also
                fun do_declaration declaration
                    =
                    case declaration
                        #
                        FIELD_DECLARATIONS (named_fields, type_variables)
                            =>
                            {   named_fields
                                    =
                                    do_named_fields  (named_fields, []);

                                if *inserted_synthesized_code

                                    # Delete from syntax tree:
                                    #
                                    NULL;

                                else

                                    inserted_synthesized_code := TRUE;

                                    # Replace with synthesized code:
                                    #
                                    THE *rewritten_synthesized_code;
                                fi;
                            };


                        VALUE_DECLARATIONS (named_values, type_variables)
                            =>
                            THE (VALUE_DECLARATIONS (do_named_values (named_values, []), type_variables ));

                        EXCEPTION_DECLARATIONS named_exceptions                             => THE declaration;

                        PACKAGE_DECLARATIONS named_packages                                 => THE (PACKAGE_DECLARATIONS (do_named_packages  (named_packages, [])));

                        TYPE_DECLARATIONS named_types                                       => THE declaration;

                        GENERIC_DECLARATIONS named_generics
                            =>
                            THE (GENERIC_DECLARATIONS  (do_named_generics  (named_generics,  [])));

                        API_DECLARATIONS named_apis                                         => THE declaration;
                        GENERIC_API_DECLARATIONS named_generic_apis                         => THE declaration;

                        LOCAL_DECLARATIONS  (declaration, declaration')
                            =>
                            THE (
                                LOCAL_DECLARATIONS
                                    ( do_the_declaration  declaration,
                                      do_the_declaration  declaration'
                                    )
                            );

                        SEQUENTIAL_DECLARATIONS declarations
                            =>
                            THE (SEQUENTIAL_DECLARATIONS (do_declarations  (declarations, [])));

                        INCLUDE_DECLARATIONS paths                                          => THE declaration;
                        OVERLOADED_VARIABLE_DECLARATION _                                   => THE declaration;
                        FIXITY_DECLARATIONS { fixity, ops }                                 => THE declaration;

                        FUNCTION_DECLARATIONS
                            ( named_functions,
                              type_variables                            # This will nowadays always be NIL; used to be support for start-of-declaration type variables.
                            )
                            =>
                            case named_functions

                                [] => NULL;

                                _  => case (do_named_functions (named_functions, []))

                                          []    => if *inserted_synthesized_code
                                                       NULL;
                                                   else
                                                       inserted_synthesized_code := TRUE;
                                                       THE *rewritten_synthesized_code;
                                                   fi;

                                          other => THE (FUNCTION_DECLARATIONS (other, type_variables));
                                      esac;
                            esac;

                        RECURSIVE_VALUE_DECLARATIONS (named_recursive_values, type_variables)
                            =>
                            THE (RECURSIVE_VALUE_DECLARATIONS (do_named_recursive_values (named_recursive_values, []), type_variables));

                        NADA_FUNCTION_DECLARATIONS   (nada_named_functions,   type_variables)    => THE declaration;
                        ENUM_DECLARATIONS { datatyps, with_typs }      => THE declaration;
                        ABSTRACT_TYPE_DECLARATIONS  { abstract_typs,
                                                      with_typs,
                                                      body
                                                    }                                            => THE declaration;


                        SOURCE_CODE_REGION_FOR_DECLARATION  (declaration', source_code_region)
                            =>
                            case (do_declaration  declaration')
                                #
                                THE d => THE (SOURCE_CODE_REGION_FOR_DECLARATION (d,  source_code_region));
                                NULL  => NULL;
                            esac;

                        PRE_COMPILE_CODE string
                            =>
                            raise exception FAIL "expand-oop-syntax.pkg (PRE_COMPILE_CODE): Impossible";        # XXX SUCKO FIXME what's the correct error protocol?
                    esac

                also
                fun do_declarations ([], result)
                        =>
                        reverse result;

                    do_declarations (declaration ! rest, result)
                        =>
                        case (do_declaration  declaration)
                            THE d => do_declarations (rest,  d ! result);
                            NULL  => do_declarations (rest,      result);
                        esac;
                end;

                # Do the object-field expansions
                # in the method functions:
                #
                rewritten_synthesized_code
                    :=
                    do_the_declaration  *rewritten_synthesized_code;


                processed_declaration
                    = 
                    do_the_declaration  original_declaration;


                if *inserted_synthesized_code

                    processed_declaration;
                else
                    # This really isn't supposed to happen,
                    # so maybe we should be raising an error
                    # here instead:
                    #
                    SEQUENTIAL_DECLARATIONS
                      [
                        processed_declaration,
                        *rewritten_synthesized_code
                      ];  
                fi;
            };

    };
end;


## Code by Jeff Prothero Copyright (c) 2010-2013,
## released per terms of SMLNJ-COPYRIGHT.


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext