15.4.967  src/lib/src/property-list.pkg

## property-list.pkg

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

# Property lists using Stephen Weeks's implementation.

# This package gets used in:
#
#     src/lib/compiler/toplevel/interact/compiler-state.pkg
#     src/lib/compiler/toplevel/interact/read-eval-print-loops-g.pkg
#     src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg
#     src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg
#     src/lib/compiler/front/semantic/modules/package-property-lists.pkg
#
# Various records are equipped with property lists but I don't see
# anything being added to or read from them;  this may be someone's
# cute idea which never got used.  For my own coding I favor Crypt                                      # Crypt         is in   src/lib/core/init/pervasive.pkg
# which is arguably less cute but more practical.         -- 2015-09-04 CrT
#
package property_list
:       Property_List           # Property_List is from   src/lib/src/property-list.api
{
    Property_List =   Ref( List(Exception) );

    fun make_property_list ()
        :
        Property_List
        =
        REF [];

    fun has_properties (REF []) =>  FALSE;
        has_properties _        =>  TRUE;
    end;

    fun clear_property_list r
        =
        r := [];

    fun same_property_list (r1:  Property_List, r2)
        =
        r1 == r2;

    fun make_prop ()
        =
        {   exception EXCEPTION X; 

            fun cons (a, l)
                =
                EXCEPTION a ! l; 

            fun peek []                =>  NULL;
                peek (EXCEPTION a ! _) =>  THE a;
                peek (_ ! l)           =>  peek l;
            end;

            fun delete []                =>  [];
                delete (EXCEPTION a ! r) =>  r;
                delete (x ! r)           =>  x ! delete r;
            end;

            { cons, peek, delete };
        };

    fun make_bool ()
        =
        {   exception EXCEPTION;

            fun peek [       ]       =>  FALSE;
                peek (EXCEPTION ! _) =>  TRUE;
                peek (_ ! l)         =>  peek l;
            end;

            fun set (l, flag)
                =
                set (l, [])
                where
                    fun set ([], _)             => if flag  EXCEPTION ! l; else l;fi;
                        set (EXCEPTION ! r, xs) => if flag  l; else list::reverse_and_prepend (xs, r);fi;
                        set (x ! r, xs)         => set (r, x ! xs);
                    end;
                end;
        
            { set, peek };
        };

    fun make_property
          (
            get_property_list:   X -> Property_List,
            make_initial_value:  X -> Y
          )
        =
        {
            (make_prop()) ->   { peek, cons, delete };

            fun peek_fn a
                =
                peek (*(get_property_list a));

            fun get_f a
                =
                {   h =  get_property_list a;

                    case (peek *h)
                        #                     
                        THE b =>  b;

                        NULL => {   b  = make_initial_value a;
                                    h := cons (b, *h);
                                    b;
                                };
                    esac;
                };

            fun clr_f a
                =
                {   h = get_property_list a;

                    h := delete *h;
                };

            fun set_fn (a, x)
                =
                {   h = get_property_list a;

                    h := cons (x, delete *h);
                };

              { peek_fn, get_fn => get_f, clear_fn => clr_f, set_fn };
        };

    fun make_boolean_property (get_property_list:  X -> Property_List)
        =
        {   (make_bool ()) ->   { peek, set };

            fun get_f a
                =
                peek(*(get_property_list a));

            fun set_f (a, flag)
                =
                {   h = get_property_list a;

                    h := set(*h, flag);
                };
          
            { get_fn => get_f,
              set_fn => set_f
            };
        };

};