PreviousUpNext

15.4.625  src/lib/compiler/front/typer-stuff/types/tuples.pkg

## tuples.pkg 

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



# 'Tuples' and 'tuples' should be called 'Records' and 'records', since 
# records are the primary concept, and tuples are a derived form.   XXX BUGGO FIXME


stipulate
    package tdt =  type_declaration_types;                              # type_declaration_types        is from   src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg
herein
    api Tuples {
        #
        number_to_label:        Int -> tdt::Label;
        make_tuple_type:        Int -> tdt::Type;
        is_tuple_type:          tdt::Type -> Bool;
        make_record_type:       List( tdt::Label ) -> tdt::Type;
    };                                                                  # Api Tuples 
end;


stipulate
    package sy  =  symbol;                                              # symbol                        is from   src/lib/compiler/front/basics/map/symbol.pkg
    package wht =  word_string_hashtable;                               # word_string_hashtable         is from   src/lib/compiler/front/basics/hash/wordstr-hashtable.pkg
    package tdt =  type_declaration_types;                              # type_declaration_types        is from   src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg
herein


    package   tuples
    : (weak)  Tuples                                                    # Tuples                        is from   src/lib/compiler/front/typer-stuff/types/tuples.pkg
    {
        include package   type_declaration_types;

        Optional_Label
          #
          = NO_LABEL
          | SOME_LABEL  Label
          ;

        Optional_Type
          #
          = NO_TYPE
          | SOME_TYPE  tdt::Type
          ;

        package label_array
            =
            expanding_rw_vector_g (

                package {
                    include package   rw_vector;
                    Rw_Vector  = Rw_Vector( Optional_Label );
                    Vector     =    Vector( Optional_Label );
                    Element    =            Optional_Label;
                }
            );

        package type_array
            =
            expanding_rw_vector_g (

                package {
                    include package   rw_vector;
                    Rw_Vector  = Rw_Vector( Optional_Type );
                    Vector     =    Vector( Optional_Type );
                    Element   =             Optional_Type;
                }
            );

        exception NEW;


        # XXX BUGGO FIXME This looks like icky global mutable state
        # that will foul us up when/if we do parallel compiles
        # in different threads or such.  All such state should
        # be in a compile_state record of some type...

        type_table    =  wht::make_hashtable  { size_hint => 32,  not_found_exception => NEW  }  :   wht::Hashtable(  tdt::Type );
        #
        type_map      =  wht::get   type_table;
        note_uniqtype =  wht::set   type_table;

        fun labels_to_symbol (labels: List(Label)):  sy::Symbol
            =
            sy::make_type_symbol (cat("{ " ! wrap labels))
            where
                fun wrap [] => ["}"];
                    wrap [id] => [sy::name id, " }"];
                    wrap (id ! rest) => sy::name id ! ", " ! wrap rest;
                end;
            end;


        # This is a tweak to make similar
        # record types point to the same thing,
        # thus speeding equality testing on them:
        #
        fun make_record_type labels
            = 
            {   record_name = labels_to_symbol labels;
                #
                number     = sy::number record_name;
                name       = sy::name   record_name;

                type_map (number, name)
                except
                    NEW
                    =
                    {   type = RECORD_TYPE labels;
                        #
                        note_uniqtype ((number, name), type);
                        #
                        type;
                    };
            };

        numeric_labels
           =
           label_array::rw_vector (0, NO_LABEL);

        tuple_types
           =
           type_array::rw_vector (0, NO_TYPE);

        fun number_to_label i
            =
            case (label_array::get (numeric_labels, i))

                 NO_LABEL
                     =>
                     {   newlabel
                             =
                             sy::make_label_symbol (int::to_string i);

                         label_array::set (numeric_labels, i, SOME_LABEL (newlabel));
                         newlabel;
                     };

                 SOME_LABEL label
                     =>
                     label;
            esac;

        fun numlabels n
            =
            labels (n, NIL)
            where
                fun labels (0, result_list) =>  result_list;
                    labels (i, result_list) =>  labels (i - 1, number_to_label i ! result_list);
                end;
            end;

        fun make_tuple_type n
            =
            case (type_array::get (tuple_types, n))
                #
                NO_TYPE
                    =>
                    {   type =  make_record_type (numlabels n);
                        #
                        type_array::set  (tuple_types,  n,  SOME_TYPE type);

                        type;
                    };

                SOME_TYPE type
                    =>
                    type;
            esac;

        fun check_labels (2, NIL) =>  FALSE;   #  { 1: t } is not a tuple 
            check_labels (n, NIL) =>  TRUE;

            check_labels (n, lab ! labs)
                => 
                sy::eq (lab, number_to_label n)
                and
                check_labels (n+1, labs);
        end;

        fun is_tuple_type (RECORD_TYPE labels)
                =>
                check_labels (1, labels);

            is_tuple_type _ => FALSE;
        end;

    };          #  package tuples 
end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext