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 /sml/branches/SMLNJ/src/MLRISC/library/annotations.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/MLRISC/library/annotations.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 411 - (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 : monnier 245 structure Annotations : ANNOTATIONS =
13 :     struct
14 :    
15 :     type annotation = exn
16 :     type annotations = annotation list
17 :    
18 : monnier 411 val prettyPrinters = ref [] : (annotation -> string) list ref
19 : monnier 245
20 : monnier 411 fun attachPrettyPrinter p = prettyPrinters := p :: !prettyPrinters
21 : monnier 245
22 : monnier 411 fun toString a =
23 :     let fun pr([]) = "<"^exnName a^">"
24 :     | pr(p::ps) = (p a handle _ => pr ps)
25 :     in pr(!prettyPrinters) end
26 :    
27 : monnier 245 (*
28 :     * Look ma, a real use of generative exceptions!
29 :     *)
30 :     fun 'a new() =
31 :     let exception Annotation of 'a
32 :     fun get [] = NONE
33 :     | get (Annotation x::_) = SOME x
34 :     | get (_::l) = get l
35 :     fun put(x,[]) = [Annotation x]
36 :     | put(x,Annotation _::l) = Annotation x::l
37 :     | put(x,y::l) = y::put(x,l)
38 :     fun rmv [] = []
39 :     | rmv (Annotation _::l) = rmv l
40 :     | rmv (x::l) = x::rmv l
41 :     in { get=get, put=put, rmv=rmv }
42 :     end
43 :    
44 :     fun get f [] = NONE
45 :     | get f (x::l) = case f x of NONE => get f l | x => x
46 :    
47 :     fun rmv f [] = []
48 :     | rmv f (x::l) = if f x then rmv f l else x::rmv f l
49 :    
50 :     fun put(x,l) = x::l
51 :    
52 :     end
53 :    

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