15.4.616  src/lib/compiler/front/typer-stuff/symbolmapstack/core-access.pkg

## core-access.pkg
#
# Special access to special package named _Core.
# This point of all this is not very clear.

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


stipulate
    package csy =  core_symbol;                                 # core_symbol                   is from   src/lib/compiler/front/typer-stuff/basics/core-symbol.pkg
    package err =  error_message;                               # error_message                 is from   src/lib/compiler/front/basics/errormsg/error-message.pkg
    package fis =  find_in_symbolmapstack;                      # find_in_symbolmapstack        is from   src/lib/compiler/front/typer-stuff/symbolmapstack/find-in-symbolmapstack.pkg
    package sy  =  symbol;                                      # symbol                        is from   src/lib/compiler/front/basics/map/symbol.pkg
    package syp =  symbol_path;                                 # symbol_path                   is from   src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg
    package syx =  symbolmapstack;                              # symbolmapstack                is from   src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg
    package tdt =  type_declaration_types;                      # type_declaration_types        is from   src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg
    package vac =  variables_and_constructors;                  # variables_and_constructors    is from   src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg
herein

    # This package is mainly used in:
    #
    #     src/lib/compiler/front/typer/main/typer-junk.pkg
    #     src/lib/compiler/front/typer/main/type-core-language.pkg
    #     src/lib/compiler/back/top/translate/translate-deep-syntax-to-lambdacode.pkg
    #
    package core_access
    : (weak)    api {

                    get_variable:     (syx::Symbolmapstack, String) -> vac::Variable;
                    get_constructor:  (syx::Symbolmapstack, String) ->  tdt::Valcon;

                    get_variable'
                      :  (Void -> vac::Variable)
                      -> (syx::Symbolmapstack, String)
                      -> vac::Variable;

                    get_constructor'
                      :  (Void -> tdt::Valcon)
                      -> (syx::Symbolmapstack, String)
                      -> tdt::Valcon;

                    # Like get_constructor, but returns a
                    # bogus exception instead of failing:
                    #
                    get_exception
                      :  (syx::Symbolmapstack, String)
                      -> tdt::Valcon;

                }

    {   stipulate
            #
            exception NO_CORE;

            fun dummy_err _ _ _
                =
                raise exception NO_CORE;


            fun path name
                =
                syp::SYMBOL_PATH [ csy::core_symbol, sy::make_value_symbol name];


            fun get_core (symbolmapstack, s)
                =
                fis::find_value_via_symbol_path (symbolmapstack, path s, dummy_err);


            fun impossible m
                =
                err::impossible ("core_access: " + m);
        herein

            fun get_variable' err (x as (syx, string))
                =
                case (get_core x)
                    #
                    vac::VARIABLE r =>  r;
                    _               =>  impossible ("get_variable: " + string);
                esac
                except
                    NO_CORE = err ();

            fun get_variable (x as (syx, string))
                =
                get_variable'
                    (\\ () = impossible ("get_variable: " + string))
                    x;

            fun get_constructor' err x
                =
                case (get_core x)
                     vac::CONSTRUCTOR c => c;
                    _ => err ();
                esac
                except
                    NO_CORE = err ();

            fun get_constructor x
                =
                get_constructor'
                    (\\ () = impossible "get_constructor")
                    x;

            fun get_exception x
                =
                get_constructor'
                    (\\ () = vac::bogus_exception)
                    x;
        end;
    };
end;


# (C) 2001 Lucent Technologies, Bell Labs
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.