1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89
|
(*
* 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([]) = ""
| pr(p::ps) = (p a handle _ => pr ps)
in pr(!prettyPrinters) end
(*
* Look ma, a real use of generative exceptions!
*)
fun 'a new(toString) =
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 toString of
NONE => ()
| SOME f => attachPrettyPrinter(fn Annotation x => f x | e => raise e);
{ get=get, peek=peek, lookup=lookup, contains=contains,
set=set, rmv=rmv, create=Annotation
}
end
fun 'a new'{create, toString, get=get'} =
let fun get [] = NONE
| get (x::l) = SOME(get' x) handle _ => get l
fun peek x = SOME(get' x) handle _ => NONE
fun lookup [] = raise NoProperty
| lookup (x::l) = get' x handle _ => lookup l
fun contains [] = false
| contains (x::l) = (get' x; true) handle _ => contains l
fun set(x,[]) = [create x]
| set(x,a::l) = (get' a; create x::l) handle _ => a::set(x,l)
fun rmv [] = []
| rmv (x::l) = (get' x; rmv l) handle _ => x::rmv l
in attachPrettyPrinter(toString o get');
{ get=get, peek=peek, lookup=lookup, contains=contains,
set=set, rmv=rmv, create=create
}
end
end
|