PreviousUpNext

15.4.638  src/lib/compiler/front/typer/main/include.pkg

## include.pkg 

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

stipulate
    package err =  error_message;                       # error_message                 is from   src/lib/compiler/front/basics/errormsg/error-message.pkg
    package ip  =  inverse_path;                        # inverse_path                  is from   src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg
    package mld =  module_level_declarations;           # module_level_declarations     is from   src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg
    package mp  =  stamppath;                           # stamppath                     is from   src/lib/compiler/front/typer-stuff/modules/stamppath.pkg
    package mj  =  module_junk;                         # module_junk                   is from   src/lib/compiler/front/typer-stuff/modules/module-junk.pkg
    package sta =  stamp;                               # stamp                         is from   src/lib/compiler/front/typer-stuff/basics/stamp.pkg
    package sxe =  symbolmapstack_entry;                # symbolmapstack_entry          is from   src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack-entry.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 ts  =  typer_junk;                          # typer_junk                    is from   src/lib/compiler/front/typer/main/typer-junk.pkg
    package tu  =  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
    package vh  =  varhome;                             # varhome                       is from   src/lib/compiler/front/typer-stuff/basics/varhome.pkg
    #
#    include module_level_declarations;
herein

    package include_mumble: (weak) Include {            # Include               is from   src/lib/compiler/front/typer/main/include.api

        fun bug msg
            =
            err::impossible ("Include: " + msg);

        debugging = REF FALSE;
        say       = control_print::say;

        fun if_debugging_say (msg: String)
            =
            if *debugging
                say msg;
                say "\n";
            fi;

        fun add_element (element, elements)
            =
            element ! elements;

        fun subst_elem (   new as (name, spec),
                         (old as (name',   _)) ! rest
                      )
                =>
                if (sy::eq (name, name'))    new ! rest;
                else                         old ! subst_elem (new, rest);
                fi;

            subst_elem (_, NIL)
                =>
                bug "substElem";
        end;

        Tyc_Compat = KEEP_OLD
                   | REPLACE
                   | INCOMPATIBLE;

        fun compatible (newtyc, oldtyc)
            =
            if (  tu::typ_arity newtyc
               != tu::typ_arity oldtyc
               )
                #
                INCOMPATIBLE;
            else
                case (newtyc, oldtyc)
                    #
                    ( ty::PLAIN_TYP { kind,  ... },
                      ty::PLAIN_TYP { kind => kind', ... }
                    )
                        =>
                        case (kind, kind')
                            #
                            (ty::FORMAL, ty::FORMAL)   => KEEP_OLD;
                            (         _, ty::FORMAL)   => REPLACE;
                            _                          => INCOMPATIBLE;
                        esac;

                    _ => INCOMPATIBLE;
                esac;
            fi;

        fun specified (symbol, elements)
            =
            list::exists
                (fn (n, _) =  sy::eq (symbol, n))
                elements;

        #  Typechecking IMPORT_IN_API in apis: 

        #  XXX BUGGO FIXME Currently doesn't deal with general api_expression case (e.g. sigid where ...) 

        fun typecheck_include (

                mld::API
                  {
                    stamp,
                    api_elements =>  new_elements,
                    symbols      =>  new_symbols, 
                    property_list,
                    type_sharing,
                    package_sharing, 
                    name,
                    closed,
                    contains_generic,
                    stub
                },
                old_dictionary,
                old_elements,
                old_symbols,
                old_slots,
                source_code_region,
                per_compile_info as { make_fresh_stamp, error_fn, ... } : ts::Per_Compile_Info
            )
                =>
                {   err =   error_fn  source_code_region;

                    # When including a list of specs into the current api;
                    # some typ's macroExpansionVars might be adjusted,
                    # this would force all the types in the specs to be adjusted also.
                    # This adjustment is implemented using this tycmap table.
                    #
                    exception TYP_MAP;

                    tyc_map =  REF ([]: List( (sta::Stamp, ty::Typ) ));

                    fun add_map z   =    tyc_map := (z ! *tyc_map);
                    fun get_map z   =   *tyc_map;

                    fun get_typ_map (ev, [])
                            =>
                            raise exception TYP_MAP;

                        get_typ_map
                          (
                            ev,
                           (ev', typ)  !  rest
                          )
                            =>
                            if (mp::same_module_stamp (ev, ev'))  typ;
                            else                                  get_typ_map (ev, rest);
                            fi;
                    end;

                    # adjust_type does not get inside each
                    # DEFINED_TYP's body
                    # because we assume that the body
                    # has been adjusted already:
                    #
                    fun adjust_type (type, []    )
                            =>
                            type;

                        adjust_type (type, tycmap)
                            =>
                            tu::map_constructor_type_dot_typ
                                newtyc
                                type
                            where
                                fun newtyc (typ as ty::TYP_BY_STAMPPATH { stamppath => [ev], ... } )
                                        => 
                                        get_typ_map (ev, tycmap)
                                        except
                                            TYP_MAP
                                            =
                                            typ;


                                    newtyc  typ
                                        =>
                                        typ;
                                end;
                            end;
                    end;

                    # adjust_typ() is only
                    # called at each type specification site.
                    #
                    # The stamp for DEFINED_TYP
                    # is changed; fortunately, this is OK
                    # because all other references to this
                    # DEFINED_TYP are via
                    # ty::TYP_BY_STAMPPATH.
                    #
                    fun adjust_typ (typ, []    )
                            =>
                            typ;

                        adjust_typ (typ, tycmap)
                            =>
                            case typ
                                #
                                ty::DEFINED_TYP
                                  {
                                    strict,
                                    path,
                                    stamp => s,
                                    type_scheme => ty::TYPE_SCHEME { arity, body }
                                  }
                                    =>
                                    ty::DEFINED_TYP
                                      {
                                        strict,
                                        path,
                                        stamp  => make_fresh_stamp(),
                                        #
                                        type_scheme => ty::TYPE_SCHEME { arity,
                                                                         body  => adjust_type (body, tycmap)
                                                                       }
                                      };

                                 ty::PLAIN_TYP _
                                     =>
                                     typ;

                                 ty::TYP_BY_STAMPPATH { stamppath => [ev], ... }
                                     => 
                                     (   get_typ_map (ev, tycmap)
                                         except
                                             TYP_MAP
                                             =
                                             typ
                                     );

                                _ => bug "adjust_typ";
                            esac;
                    end 

                    # Changing the stamp of an ANONYMOUS
                    # api may cause unnecessary
                    # api matching operations:
                    #
                    also
                    fun adjust_sig (an_api, [])
                            =>
                            an_api;

                        adjust_sig
                            (

                                an_api as

                                    mld::API {

                                        stamp,
                                        name,
                                        closed,
                                        contains_generic, 
                                        api_elements,
                                        symbols,
                                        property_list,
                                        type_sharing,
                                        package_sharing,
                                        stub
                                    },

                                tycmap
                            )
                            =>
                            if closed
                                an_api;
                            else
                                mld::API {
                                    stamp  => make_fresh_stamp(),
                                    name,
                                    closed => FALSE,
                                    stub   => NULL,

                                    property_list =>  property_list::make_property_list (),
                                    api_elements  =>  adjust_elems (api_elements, tycmap), 
                                    symbols,
                                    type_sharing, 

                                    contains_generic,
                                    package_sharing
                                };
                           fi;

                       adjust_sig _
                           =>
                           bug "adjust_sig";
                    end 

                    also
                    fun adjust_generic_api (

                            an_api as

                                mld::GENERIC_API {
                                    kind,
                                    parameter_api,
                                    body_api,
                                    parameter_variable,
                                    parameter_symbol
                                },

                            tycmap
                        )
                            =>
                            {   parameter_api' = adjust_sig (parameter_api, tycmap);
                                body_api' = adjust_sig (body_api, tycmap);

                                mld::GENERIC_API {
                                    kind,
                                    parameter_api => parameter_api',
                                    body_api      => body_api',
                                    parameter_variable,
                                    parameter_symbol
                                };
                            };

                        adjust_generic_api _
                            =>
                            bug "adjust_generic_api";
                    end 

                    also
                    fun adjust_elems (api_elements, tycmap)
                        =
                        map   (adjust_elem tycmap)   api_elements

                    also
                    fun adjust_elem tycmap (symbol, spec)
                        =
                        {   nspec
                                = 
                                case spec
                                    #
                                    mld::TYP_IN_API
                                      {
                                        typ,
                                        module_stamp =>  ev,
                                        is_a_replica =>  r,
                                        scope        =>  s
                                      }
                                        =>
                                        mld::TYP_IN_API
                                          {
                                            typ       =>  adjust_typ (typ, tycmap),
                                            module_stamp =>  ev,
                                            is_a_replica =>  r,
                                            scope        =>  s
                                        };

                                    mld::PACKAGE_IN_API
                                      {
                                        an_api,
                                        module_stamp =>  ev,
                                        definition   =>  d,
                                        slot         =>  s
                                      }
                                        =>
                                        mld::PACKAGE_IN_API
                                          {
                                            an_api       =>  adjust_sig (an_api, tycmap),
                                            module_stamp =>  ev,
                                            definition   =>  d,
                                            slot         =>  s
                                          };
                                      #  BUG: def component may need adjustment? XXX FIXME BUGGO 

                                    mld::GENERIC_IN_API { a_generic_api,                                               module_stamp=>ev, slot=>s }
                                        =>
                                        mld::GENERIC_IN_API { a_generic_api => adjust_generic_api (a_generic_api, tycmap), module_stamp=>ev, slot=>s };

                                    mld::VALUE_IN_API { type,                            slot }
                                        =>
                                        mld::VALUE_IN_API { type=>adjust_type (type, tycmap), slot };

                                    mld::VALCON_IN_API
                                      {
                                        slot => s,
                                        #
                                        datatype =>   ty::VALCON
                                                          {
                                                            form, 
                                                            name,
                                                            type,
                                                            is_constant,
                                                            signature,
                                                            is_lazy
                                                         }
                                      }
                                    =>
                                        mld::VALCON_IN_API
                                          {
                                            slot => s,
                                            #
                                            datatype =>   ty::VALCON
                                                              {
                                                                name,
                                                                is_constant,
                                                                is_lazy,
                                                                #
                                                                form,
                                                                signature,
                                                                #       
                                                                type => adjust_type (type, tycmap)
                                                              }
                                        };
                                esac;

                            (symbol, nspec);
                        };

                    fun add_elem ((name, nspec: mld::Api_Element), dictionary, elems, syms, slot)
                        =
                        case nspec
                            #
                            mld::TYP_IN_API
                              {
                                typ       =>  tc,
                                module_stamp =>  ev,
                                is_a_replica =>  r,
                                scope        =>  s
                              }
                                =>
                                {   my { typ => otc,   module_stamp => oev,   is_a_replica => or_op,   scope => os }  #  'o' for 'old'? 
                                        =
                                        case (mj::get_api_element (elems, name))
                                            #
                                            mld::TYP_IN_API x =>   x;
                                            _                    =>   bug "addElem: TYP_IN_API";
                                        esac;

                                    case (compatible (tc, otc))

                                        KEEP_OLD
                                            => 
                                            {   ntc =
                                                    ty::TYP_BY_STAMPPATH
                                                      {
                                                        arity       =>  tu::typ_arity otc,
                                                        stamppath =>  [oev],
                                                        path        =>  ip::INVERSE_PATH [name]
                                                      };

                                                add_map (ev, ntc);

                                                (dictionary, elems, syms, slot);
                                            };

                                       REPLACE
                                           =>
                                           {   ntc   =   adjust_typ (tc, get_map());

                                               nspec' =
                                                   mld::TYP_IN_API
                                                     {
                                                       typ       =>  ntc,
                                                       module_stamp =>  oev,
                                                       is_a_replica =>  or_op,
                                                       scope        =>  s
                                                     };                              # ? XXX BUGGO FIXME

                                               elems' = subst_elem ( (name, nspec'), elems);

                                               ntc = ty::TYP_BY_STAMPPATH
                                                       {
                                                         arity       =>  tu::typ_arity ntc,
                                                         stamppath =>  [oev],
                                                         path        =>  ip::INVERSE_PATH [name]
                                                       };

                                               add_map (ev, ntc);

                                               (dictionary, elems', syms, slot);
                                           };

                                       INCOMPATIBLE
                                           =>
                                           {   err
                                                   err::ERROR
                                                   (   "duplicate specifications for type "
                                                   +   sy::name name
                                                   +   " caused by include"
                                                   )
                                                   err::null_error_body; 

                                               (dictionary, elems, syms, slot);
                                           };
                                    esac;

                                }   except
                                        mj::UNBOUND _
                                        =
                                        #  New typ 
                                        {   ntyc
                                                =
                                                ty::TYP_BY_STAMPPATH
                                                  {
                                                    arity       =>  tu::typ_arity tc,
                                                    stamppath =>  [ev],
                                                    path        =>  ip::INVERSE_PATH [name]
                                                  };

                                            dictionary'
                                                =
                                                syx::bind (
                                                    name,
                                                    sxe::NAMED_TYPE ntyc,
                                                    dictionary
                                                );

                                            spec' =
                                                mld::TYP_IN_API
                                                  {
                                                    typ       =>  adjust_typ (tc, get_map()),
                                                    module_stamp =>  ev,
                                                    is_a_replica =>  r,
                                                    scope        =>  s
                                                  };

                                            elems' =  add_element( (name, spec'), elems);

                                            syms'  =  name ! syms;

                                            (dictionary', elems', syms', slot);
                                        };


                        mld::PACKAGE_IN_API { an_api, module_stamp, definition, ... }
                            =>
                            if (specified (name, elems))
                                #
                                err
                                     err::ERROR
                                     (   "duplicate specifications for package "
                                     +   sy::name name
                                     +   " caused by include"
                                     )
                                     err::null_error_body;

                                 (dictionary, elems, syms, slot);

                            else 
                                #  New specification is ok: 

                                newsign =   adjust_sig (an_api, get_map());

                                newspec =
                                    mld::PACKAGE_IN_API
                                      {
                                        an_api => newsign,
                                        slot,
                                        module_stamp,
                                        definition
                                      };

                                nstr =
                                    mld::PACKAGE_API {
                                        an_api => newsign,
                                        stamppath   => [module_stamp]
                                    };

                                dictionary'
                                    =
                                    syx::bind (
                                        name,
                                        sxe::NAMED_PACKAGE nstr,
                                        dictionary
                                    );

                                elems' =  add_element ((name, newspec), elems);

                                syms'  =  name ! syms;

                                (dictionary', elems', syms', slot+1);
                            fi;


                          mld::GENERIC_IN_API { a_generic_api, module_stamp, ... }
                             =>
                             if (specified (name, elems))
                                 #
                                 err
                                     err::ERROR
                                     (   "duplicate specifications for generic package "
                                     +   sy::name name
                                     +   " caused by include"
                                     )
                                     err::null_error_body;

                                 (dictionary, elems, syms, slot);

                             else
                                 #  New specification is ok: 

                                 newsign
                                     =
                                     adjust_generic_api (a_generic_api, get_map());

                                 newspec
                                     =
                                     mld::GENERIC_IN_API
                                       {
                                         a_generic_api             => newsign,
                                         slot,
                                         module_stamp
                                       };

                                 elems'
                                     =
                                     add_element ((name, newspec), elems);

                                 syms'
                                     =
                                     name ! syms;

                                 (dictionary, elems', syms', slot+1);

                             fi;


                          mld::VALUE_IN_API { type, ... }
                              => 
                              if (specified (name, elems))

                                   err
                                       err::ERROR
                                       (   "duplicate value specifications for "
                                       +   sy::name name
                                       +   " caused by include"
                                       )
                                       err::null_error_body;

                                   (dictionary, elems, syms, slot);


                              else #  New specification is ok: 

                                  newtyp  =   adjust_type (type, get_map());

                                  newspec =   mld::VALUE_IN_API { type => newtyp,   slot };

                                  elems'  =   add_element ((name, newspec), elems);

                                  syms'   =   name ! syms;

                                  (dictionary, elems', syms', slot+1);
                              fi;

                         mld::VALCON_IN_API
                           {
                              datatype => ty::VALCON
                                              {
                                                form,
                                                name,
                                                type,
                                                is_constant,
                                                signature,
                                                is_lazy
                                              },
                            ...
                          }
                              =>
                              if (specified (name, elems))
                                   #
                                   err
                                        err::ERROR
                                        (   "duplicate constructor specifications for "
                                        +   sy::name name
                                        +   " caused by include"
                                        )
                                        err::null_error_body;

                                    (dictionary, elems, syms, slot);


                              else #  New specification is ok: 

                                  type
                                      =
                                      adjust_type (type, get_map());

                                  ndcon =
                                      ty::VALCON
                                        {
                                          type,
                                          signature,
                                          form,
                                          name,
                                          is_constant,
                                          is_lazy
                                      };

                                  my (slot_op, slot')
                                      =
                                      case form
                                          #
                                          vh::EXCEPTION _ => (THE slot, slot+1);
                                          _               => (NULL,      slot  );
                                      esac;

                                  newspec
                                      =
                                      mld::VALCON_IN_API {
                                          #
                                          datatype => ndcon,
                                          slot      => slot_op
                                      };

                                  elems' = add_element( (name, newspec), elems);

                                  syms'  = name ! syms;

                                  (dictionary, elems', syms', slot');
                               fi;
                       esac;                                                             # fun add_elem 

                    fun add_elems (nelems, [], dictionary, elems, syms, slot)
                            =>
                            (dictionary, elems, syms, slot);

                        add_elems (e ! nelems, s ! rest, dictionary, elems, syms, slot)
                            => 
                            {   # Should use s to search for e in nelems if
                                # elements is represented as a real dictionary. XXX BUGGO FIXME

                                my (dictionary', elems', syms', slot')
                                    =
                                    add_elem (e, dictionary, elems, syms, slot);

                                add_elems (nelems, rest, dictionary', elems', syms', slot');
                            };

                        add_elems _
                            =>
                            bug "add_elems";
                    end;

                    my (dictionary', elems', syms', slots')
                        = 
                        add_elems (

                            new_elements,
                            new_symbols,
                            old_dictionary,
                            old_elements,
                            old_symbols,
                            old_slots
                        );


                    (dictionary', elems', syms', type_sharing, package_sharing, slots', contains_generic);

                };  #  end of case #1 for function typecheck_include 

            typecheck_include (mld::ERRONEOUS_API, dictionary, elems, syms, slots, source_code_region, comp_info)
                =>
                (dictionary, elems, syms, [], [], slots, FALSE);
        end;                                                            # fun typecheck_include

    };                                                                  # package include 
end;                                                                    # stipulate


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext