15.4.887  src/lib/src/expanding-rw-vector-g.pkg

## unbounded-rw-vector-g.pkg
#
# rw_vectors of unbounded length
#
# Compare with
#
#     src/lib/src/dynamic-rw-vector.pkg
#
# Do we need both?

# Compiled by:
#     src/lib/std/standard.lib



###        "It is difficult to steer a parked car, so get moving."
###
###                                -- Henrietta Mears


# This generic gets invoked in:
#
#     src/lib/compiler/src/fconst/slow-portable-floating-point-constants-g.pkg
#     src/lib/compiler/front/typer-stuff/types/tuples.pkg


stipulate
    package xns =  exceptions;                                                  # exceptions                            is from   src/lib/std/exceptions.pkg
herein

    generic package   expanding_rw_vector_g   (
        #             =====================
        #
        rwv:  Typelocked_Rw_Vector                                              # Typelocked_Rw_Vector                  is from   src/lib/std/src/typelocked-rw-vector.api
    )
    : (weak) Typelocked_Expanding_Rw_Vector                                     # Typelocked_Expanding_Rw_Vector        is from   src/lib/src/typelocked-expanding-rw-vector.api
    {
        Element = rwv::Element;

        Rw_Vector = BLOCK  (Ref( rwv::Rw_Vector ), Element, Ref( Int ));

        exception INDEX_OUT_OF_BOUNDS   =  xns::INDEX_OUT_OF_BOUNDS;
        exception SIZE                  =  xns::SIZE;

        fun rw_vector (size, default)
            =
            BLOCK (REF (rwv::make_rw_vector (size, default)), default, REF (-1));

        # from_list (l, v) creates an rw_vector using the list of values l
        # plus the default value v.
        # NOTE: Once Typelocked_Rw_Vector includes arrayoflist, this will become trivial.
        #
        fun from_list (init_list, default)
            =
            {   len = length init_list;
                vector = rwv::make_rw_vector (len, default);

                fun set ([], _)    =>  ();
                    set (x ! r, i) =>  { rwv::set (vector, i, x);   set (r, i+1); };
                end;

                set (init_list, 0);
                BLOCK (REF vector, default, REF (len - 1));
            };


        # from_fn (size, fill, default) acts like rw_vector::from_fn,
        # plus  stores default value default.  Raises SIZE if size < 0.
        #
        fun from_fn (size, fill_g, default)
            =
            BLOCK (REF (rwv::from_fn (size, fill_g)), default, REF (size - 1));

        fun copy_rw_subvector (BLOCK (vector, default, bnd), lo, hi)
            =
            {   arrval = *vector;
                bnd = *bnd;

                fun copy i
                    =
                    rwv::get (arrval, i+lo);

                if   (hi <= bnd)  BLOCK (REF (rwv::from_fn (hi-lo,  copy)), default, REF (hi-lo));
                elif (lo <= bnd)  BLOCK (REF (rwv::from_fn (bnd-lo, copy)), default, REF (bnd-lo));
                else              rw_vector (0, default);
                fi;
            };

        fun default (BLOCK(_, default, _))
            =
            default;

        fun get (BLOCK (vector, default, _), idx)
            =
            (rwv::get (*vector, idx)) 
            except
                INDEX_OUT_OF_BOUNDS =  if (idx < 0)   raise exception INDEX_OUT_OF_BOUNDS;
                                       else           default;
                                       fi;

        fun bound (BLOCK(_, _, bnd))
            =
            *bnd;

        fun expand (vector, oldlen, newlen, default)
            =
            rwv::from_fn (newlen, fillfn)
            where
                fun fillfn i
                    =
                    if (i < oldlen)   rwv::get (vector, i);
                    else              default;
                    fi;
            end;

        fun set (BLOCK (vector, default, bnd), idx, v)
            =
            {   len =  rwv::length *vector;
                #          
                if (idx >= len)
                     vector :=  expand (*vector, len, int::max (len+len, idx+1), default); 
                fi;

                rwv::set (*vector, idx, v);

                if (*bnd <  idx   )
                     bnd := idx;
                fi;
            };

        fun truncate (a as BLOCK (vector, default, bndref), size)
            =
            {   bnd    = *bndref;
                newbnd =  size - 1;
                v      = *vector;

                vector_length = rwv::length v;

                fun fill_default (i, stop)
                    =
                    if (i != stop)
                        #       
                        rwv::set (v, i, default);
                        fill_default (i - 1, stop);
                    fi;

                if (newbnd < 0)
                    #
                    bndref := -1;
                    vector :=  rwv::make_rw_vector (0, default);
                else
                    if (newbnd < bnd)
                        #       
                        if (3 * size < vector_length)
                            #
                            (copy_rw_subvector (a, 0, newbnd))
                                ->
                                BLOCK (vector', _, bnd');

                            bndref :=  *bnd';
                            vector :=  *vector';
                        else
                            fill_default (bnd, newbnd);
                        fi;
                    fi;
                fi;
            };

    };                                                  # generic package expanding_rw_vector_g
end;


## COPYRIGHT (c) 1993 by AT&T Bell Laboratories.  See SMLNJ-COPYRIGHT file for details.
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.