15.4.648  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 tdt =  type_declaration_types;                      # type_declaration_types        is from   src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg
herein
    api Typevar_Set {

         Typevar_Set;

         empty:      Typevar_Set;

         singleton:  tdt::Typevar_Ref  ->  Typevar_Set;

         make_typevar_set:  List( tdt::Typevar_Ref )  ->  Typevar_Set;

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

         get_elements:  Typevar_Set  ->  List( tdt::Typevar_Ref );

    };
end;

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

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

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

        fun is_member
                (                           a as REF (USER_TYPEVAR { name=>name_a, eq=>eq_a, fn_nesting=>fn_nesting_a } ), 
                  { id => _, ref_typevar => b as REF (USER_TYPEVAR { 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_TYPEVAR typevars are created with fn_nesting == infinity
                    # and this should not change until type checking is done

                    a := RESOLVED_TYPEVAR
                           (TYPEVAR_REF
                               (tdt::make_typevar_ref' (b, ["is_member  from  typevar_set"])));

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

           is_member _ => FALSE;
        end;

        fun is_member_pure
                (
                                          (a as REF (USER_TYPEVAR { name=>name_a, ... } )), 
                 { id => _, ref_typevar => b as REF (USER_TYPEVAR { 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 typevar_set 
end;                                                                    # stipulate



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