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

SCM Repository

[smlnj] Diff of /sml/branches/SMLNJ/src/MLRISC/library/annotations.sml
ViewVC logotype

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

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 411, Fri Sep 3 00:25:03 1999 UTC revision 469, Wed Nov 10 22:42:52 1999 UTC
# Line 9  Line 9 
9   *  -- Allen   *  -- Allen
10   *)   *)
11    
12  structure Annotations : ANNOTATIONS =  structure Annotations :> ANNOTATIONS =
13  struct  struct
14    
15     type annotation = exn     type annotation = exn
16     type annotations = annotation list     type annotations = annotation list
17       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    
30     val prettyPrinters = ref [] : (annotation -> string) list ref     val prettyPrinters = ref [] : (annotation -> string) list ref
31    
# Line 27  Line 39 
39     (*     (*
40      * Look ma, a real use of generative exceptions!      * Look ma, a real use of generative exceptions!
41      *)      *)
42     fun 'a new() =     fun 'a new(prettyPrinter) =
43     let exception Annotation of 'a     let exception Annotation of 'a
44         fun get [] = NONE         fun get [] = NONE
45           | get (Annotation x::_) = SOME x           | get (Annotation x::_) = SOME x
46           | get (_::l) = get l           | get (_::l) = get l
47         fun put(x,[]) = [Annotation x]         fun peek(Annotation x) = SOME x
48           | put(x,Annotation _::l) = Annotation x::l           | peek _ = NONE
49           | put(x,y::l) = y::put(x,l)         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         fun rmv [] = []         fun rmv [] = []
59           | rmv (Annotation _::l) = rmv l           | rmv (Annotation _::l) = rmv l
60           | rmv (x::l) = x::rmv l           | rmv (x::l) = x::rmv l
61     in  { get=get, put=put, rmv=rmv }     in  case prettyPrinter of
62             SOME f => attachPrettyPrinter(fn Annotation x => f x | e => raise e)
63           | NONE => ();
64           { get=get, peek=peek, lookup=lookup, contains=contains,
65             set=set, rmv=rmv, create=Annotation
66           }
67     end     end
68    
69     fun get f []     = NONE     fun newFlag ""   = new NONE
70       | get f (x::l) = case f x of NONE => get f l | x => x       | newFlag name = new(SOME(fn _ => name))
   
    fun rmv f [] = []  
      | rmv f (x::l) = if f x then rmv f l else x::rmv f l  
   
    fun put(x,l) = x::l  
71    
72  end  end
73    

Legend:
Removed from v.411  
changed lines
  Added in v.469

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