Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] View of /MLRISC/releases/release-110.60/library/annotations.sml
ViewVC logotype

View of /MLRISC/releases/release-110.60/library/annotations.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 469 - (download) (annotate)
Wed Nov 10 22:42:52 1999 UTC (19 years, 10 months ago) by monnier
Original Path: sml/branches/SMLNJ/src/MLRISC/library/annotations.sml
File size: 2097 byte(s)
version 110.23
(*
 *  User definable annotations.
 *
 *  Note: annotations will now be used extensively in all part of
 *  the optimizer.
 *
 *  Idea is stolen from Stephen Weeks
 * 
 *  -- Allen
 *)

structure Annotations :> ANNOTATIONS =
struct

   type annotation = exn
   type annotations = annotation list
   type propList = annotations
   exception NoProperty
   type 'a property = 
         { get      : annotations -> 'a option,
           peek     : annotation -> 'a option,
           lookup   : annotations -> 'a,
           contains : annotations -> bool,
           set      : 'a * annotations -> annotations,
           rmv      : annotations -> annotations,
           create   : 'a -> annotation
         }
   type flag = unit property

   val prettyPrinters = ref [] : (annotation -> string) list ref 

   fun attachPrettyPrinter p = prettyPrinters := p :: !prettyPrinters

   fun toString a =
   let fun pr([]) = "<"^exnName a^">"
         | pr(p::ps) = (p a handle _ => pr ps)
   in  pr(!prettyPrinters) end

   (*
    * Look ma, a real use of generative exceptions!
    *)
   fun 'a new(prettyPrinter) =
   let exception Annotation of 'a
       fun get [] = NONE
         | get (Annotation x::_) = SOME x
         | get (_::l) = get l
       fun peek(Annotation x) = SOME x
         | peek _ = NONE
       fun lookup [] = raise NoProperty
         | lookup (Annotation x::_) = x
         | lookup (_::l) = lookup l
       fun contains [] = false
         | contains (Annotation _::_) = true
         | contains (_::l) = contains l
       fun set(x,[]) = [Annotation x]
         | set(x,Annotation _::l) = Annotation x::l
         | set(x,y::l) = y::set(x,l)
       fun rmv [] = []
         | rmv (Annotation _::l) = rmv l
         | rmv (x::l) = x::rmv l
   in  case prettyPrinter of
         SOME f => attachPrettyPrinter(fn Annotation x => f x | e => raise e)
       | NONE => ();
       { get=get, peek=peek, lookup=lookup, contains=contains,
         set=set, rmv=rmv, create=Annotation
       }
   end
 
   fun newFlag ""   = new NONE
     | newFlag name = new(SOME(fn _ => name))

end


root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0