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

SCM Repository

[smlnj] Annotation of /MLRISC/releases/release-110.84/library/annotations.sml
ViewVC logotype

Annotation of /MLRISC/releases/release-110.84/library/annotations.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 4728 - (view) (download)

1 : monnier 411 (*
2 :     * User definable annotations.
3 :     *
4 :     * Note: annotations will now be used extensively in all part of
5 :     * the optimizer.
6 :     *
7 :     * Idea is stolen from Stephen Weeks
8 :     *
9 :     * -- Allen
10 :     *)
11 :    
12 : george 545 structure Annotations : ANNOTATIONS =
13 : monnier 245 struct
14 :    
15 :     type annotation = exn
16 :     type annotations = annotation list
17 : monnier 469 type propList = annotations
18 :     exception NoProperty
19 :     type 'a property =
20 :     { get : annotations -> 'a option,
21 :     peek : annotation -> 'a option,
22 :     lookup : annotations -> 'a,
23 :     contains : annotations -> bool,
24 :     set : 'a * annotations -> annotations,
25 :     rmv : annotations -> annotations,
26 :     create : 'a -> annotation
27 :     }
28 :     type flag = unit property
29 : monnier 245
30 : monnier 411 val prettyPrinters = ref [] : (annotation -> string) list ref
31 : monnier 245
32 : monnier 411 fun attachPrettyPrinter p = prettyPrinters := p :: !prettyPrinters
33 : monnier 245
34 : monnier 411 fun toString a =
35 : monnier 498 let fun pr([]) = ""
36 : monnier 411 | pr(p::ps) = (p a handle _ => pr ps)
37 :     in pr(!prettyPrinters) end
38 :    
39 : monnier 245 (*
40 :     * Look ma, a real use of generative exceptions!
41 :     *)
42 : george 545 fun 'a new(toString) =
43 : monnier 245 let exception Annotation of 'a
44 :     fun get [] = NONE
45 :     | get (Annotation x::_) = SOME x
46 :     | get (_::l) = get l
47 : monnier 469 fun peek(Annotation x) = SOME x
48 :     | peek _ = NONE
49 :     fun lookup [] = raise NoProperty
50 :     | lookup (Annotation x::_) = x
51 :     | lookup (_::l) = lookup l
52 :     fun contains [] = false
53 :     | contains (Annotation _::_) = true
54 :     | contains (_::l) = contains l
55 :     fun set(x,[]) = [Annotation x]
56 :     | set(x,Annotation _::l) = Annotation x::l
57 :     | set(x,y::l) = y::set(x,l)
58 : monnier 245 fun rmv [] = []
59 :     | rmv (Annotation _::l) = rmv l
60 :     | rmv (x::l) = x::rmv l
61 : george 545 in case toString of
62 :     NONE => ()
63 :     | SOME f => attachPrettyPrinter(fn Annotation x => f x | e => raise e);
64 : monnier 469 { get=get, peek=peek, lookup=lookup, contains=contains,
65 :     set=set, rmv=rmv, create=Annotation
66 :     }
67 : monnier 245 end
68 :    
69 : george 545 fun 'a new'{create, toString, get=get'} =
70 :     let fun get [] = NONE
71 :     | get (x::l) = SOME(get' x) handle _ => get l
72 :     fun peek x = SOME(get' x) handle _ => NONE
73 :     fun lookup [] = raise NoProperty
74 :     | lookup (x::l) = get' x handle _ => lookup l
75 :     fun contains [] = false
76 :     | contains (x::l) = (get' x; true) handle _ => contains l
77 :     fun set(x,[]) = [create x]
78 :     | set(x,a::l) = (get' a; create x::l) handle _ => a::set(x,l)
79 :     fun rmv [] = []
80 :     | rmv (x::l) = (get' x; rmv l) handle _ => x::rmv l
81 :     in attachPrettyPrinter(toString o get');
82 :     { get=get, peek=peek, lookup=lookup, contains=contains,
83 :     set=set, rmv=rmv, create=create
84 :     }
85 :     end
86 :    
87 :    
88 : monnier 245 end
89 :    

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