15.4.649  src/lib/compiler/front/typer/main/type-variable-set.pkg

## type-variable-set.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 ty  =  types;                                       # types                 is from   src/lib/compiler/front/typer-stuff/types/types.pkg
herein

    api Type_Variable_Set {

         Type_Variable_Set;

         empty:      Type_Variable_Set;

         singleton:  ty::Typevar_Ref  ->  Type_Variable_Set;

         make_type_variable_set:  List( ty::Typevar_Ref )  ->  Type_Variable_Set;

         union:      (Type_Variable_Set, Type_Variable_Set, err::Plaint_Sink)  ->  Type_Variable_Set;
         diff:       (Type_Variable_Set, Type_Variable_Set, err::Plaint_Sink)  ->  Type_Variable_Set;
         diff_pure:  (Type_Variable_Set, Type_Variable_Set                            )  ->  Type_Variable_Set;

         get_elements:  Type_Variable_Set  ->  List( ty::Typevar_Ref );

    };
end;

stipulate 
    package err =  error_message;                               # error_message         is from   src/lib/compiler/front/basics/errormsg/error-message.pkg
    package ty  =  types;                                       # types                 is from   src/lib/compiler/front/typer-stuff/types/types.pkg
    #
    fun bug msg =  err::impossible("type_variable_set: " + msg);
    #
    include types; 
herein

    package type_variable_set
    :       Type_Variable_Set                   # Type_Variable_Set     is from   src/lib/compiler/front/typer/main/type-variable-set.pkg
    {
        Type_Variable_Set = List( Typevar_Ref );

        empty = NIL;
        fun singleton t = [t];
        fun make_type_variable_set l = l;
        fun get_elements s = s;

        fun is_member
                (                           a as REF (USER_TYPE_VARIABLE { name=>name_a, eq=>eq_a, fn_nesting=>fn_nesting_a } ), 
                  { id => _, ref_typevar => b as REF (USER_TYPE_VARIABLE { name=>name_b, eq=>eq_b, fn_nesting=>fn_nesting_b } ) } ! rest,
                   err
                )
                =>
                if (a == b)
                    #
                    TRUE;

                elif (symbol::eq (name_a, name_b) )

                    if (eq_a != eq_b)
                       err err::ERROR ("type variable " + (symbol::name name_a) +
                                     " occurs with different equality properties \
                                      \in the same scope")
                           err::null_error_body;
                    fi;

                    if (fn_nesting_a != fn_nesting_b)   bug "is_member:  fn_nesting levels differ";
                    fi;

                    # USER_TYPE_VARIABLE type_variables are created with fn_nesting == infinity
                    # and this should not change until type checking is done

                    a := RESOLVED_TYPE_VARIABLE
                           (TYPE_VARIABLE_REF
                               (ty::make_type_variable_ref' (b, ["is_member  from  type_variable_set"])));

                    TRUE;
                else
                    is_member (a, rest, err);
                fi;

           is_member _ => FALSE;
        end;

        fun is_member_pure
                (
                                          (a as REF (USER_TYPE_VARIABLE { name=>name_a, ... } )), 
                 { id => _, ref_typevar => b as REF (USER_TYPE_VARIABLE { name=>name_b, ... } ) } ! rest
                )
                =>
                if   (a == b)                       TRUE;
                elif (symbol::eq (name_a, name_b))  TRUE;
                else                                is_member_pure (a, rest);
                fi;

            is_member_pure _ => FALSE;
        end;

        fun union([], s, err) => s;
            union (s,[], err) => s;

            union ((v as { id, ref_typevar => a }) ! r,  s,  err)
               =>
               if (is_member (a, s, err) )      union (r, s, err);
               else                         v ! union (r, s, err);
               fi;
        end;

        fun diff (s,[], err) => s;
            diff([], _, err) => [];

            diff ((v as { id, ref_typevar => a }) ! r, s, err)
               =>
               if (is_member (a, s, err) )     diff (r, s, err);
               else                        v ! diff (r, s, err);
               fi;
        end;

        fun diff_pure (s,[]) => s;
            diff_pure([], _) => [];

            diff_pure ((v as { id, ref_typevar => a }) ! r, s)
               =>
               if (is_member_pure (a, s) )      diff_pure (r, s);
               else                         v ! diff_pure (r, s);
               fi;
        end;

    };                                                                  # package type_variable_set 
end;                                                                    # stipulate



## COPYRIGHT (c) 1996 Bell Laboratories.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2013,
## released per terms of SMLNJ-COPYRIGHT.