PreviousUpNext

15.4.935  src/lib/src/note.pkg

## note.pkg
#
#  User definable annotations.
#
#  Note: annotations will henceforth be used
#  extensively in all parts of the optimizer.
#
#  Idea is stolen from Stephen Weeks

#  -- Allen Leung
#
# See also comments in
#
#     src/lib/std/standard.lib

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

package   note
: (weak)  Note                                                  # Note  is from   src/lib/src/note.api
{
    Note  = Exception;
    Notes = List( Note );

    exception NO_NOTE_FOUND;

    Notekind(X)
        = 
        { get:       Notes -> Null_Or(X),
          peek:      Note -> Null_Or(X),
          lookup:    Notes -> X,
          is_in:     Notes -> Bool,
          set:      (X, Notes) -> Notes,
          rmv:       Notes -> Notes,
          x_to_note: X -> Note
        };

    Flag =   Notekind( Void );

    prettyprinters
        =
        REF []:  Ref( List( Note -> String ) );                 # XXX BUGGO FIXME icky thread-hostile mutable global state.


    fun attach_prettyprinter p
        =
        prettyprinters
            :=
            p ! *prettyprinters;

    fun to_string a
        =
        print *prettyprinters
        where
            fun print ([])     => "";
                print (p ! ps) => (p a except _ = print ps);
            end;
        end;


    # Look ma, a real use of generative exceptions!
    #
    fun make_notekind  to_string
        =
        {   exception NOTE(X);

            fun get [] => NULL;
                get (NOTE x ! _) => THE x;
                get (_ ! l) => get l;
            end;

            fun peek (NOTE x) => THE x;
                peek _ => NULL;
            end;

            fun lookup [] => raise exception NO_NOTE_FOUND;
                lookup (NOTE x ! _) => x;
                lookup (_ ! l) => lookup l;
            end;

            fun is_in []           =>  FALSE;
                is_in (NOTE _ ! _) =>  TRUE;
                is_in (     _ ! l) =>  is_in l;
            end;

            fun set (x,[]) => [NOTE x];
                set (x, NOTE _ ! l) => NOTE x ! l;
                set (x, y ! l) => y ! set (x, l);
            end;

            fun rmv [] => [];
                rmv (NOTE _ ! l) =>     rmv l;
                rmv (x      ! l) => x ! rmv l;
            end;

            case to_string
                #              
                THE f  =>  attach_prettyprinter
                               fn NOTE x => f x;
                                  e      => raise exception e;
                               end;
                #
                NULL   =>  ();
            esac;

            { get, peek, lookup, is_in, set, rmv, x_to_note => NOTE };
        };

    fun make_notekind' { x_to_note, to_string, get=>get' }
        = 
        {   fun get []      =>  NULL;
                get (x ! l) =>  THE (get' x)
                                except
                                    _ =  get l;
            end;

            fun peek x
                =
                THE (get' x)
                except
                    _ =  NULL;

            fun lookup []      =>  raise exception NO_NOTE_FOUND;
                lookup (x ! l) =>  get' x 
                                   except
                                       _ =  lookup l;
            end;

            fun is_in []      =>  FALSE;
                is_in (x ! l) =>  { get' x;   TRUE; }
                                     except
                                         _ =  is_in l;
            end;

            fun set (x,[])     =>  [x_to_note x];
                set (x, a ! l) =>  { get' a;   x_to_note x ! l;}
                                   except
                                       _ =  a ! set (x, l);
            end;

            fun rmv []      =>  [];
                rmv (x ! l) =>  { get' x;   rmv l; }
                                except
                                    _ =  x ! rmv l;
            end;

            attach_prettyprinter (to_string o get');

            { get, peek, lookup, is_in, set, rmv, x_to_note };
        };
};



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext