lib/mlton/basic/property-list.fun

   1 (* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 functor PropertyList (H: HET_CONTAINER):> PROPERTY_LIST =
   9 struct
  10
  11 datatype t = T of H.t list ref
  12
  13 fun new (): t = T (ref [])
  14
  15 fun length (T r) = List.length (!r)
  16
  17 val equals = fn (T r, T r') => Ref.equals (r, r')
  18
  19 fun clear (T hs) = hs := []
  20
  21 val numPeeks: Int64.int ref = ref 0
  22 val numLinks: Int64.int ref = ref 0
  23 val maxLength: int ref = ref 0
  24
  25 fun stats () =
  26    let open Layout
  27    in align
  28       [seq [str "property list numPeeks = ", str (Int64.toString (!numPeeks))],
  29        (* seq [str "property list numLinks = ", str (Int64.toString (!numLinks))], *)
  30        seq [str "property list maxLength = ", Int.layout (!maxLength)],
  31        seq [str "property list average position = ",
  32             str let open Real
  33                     val fromInt = fromIntInf o Int64.toLarge
  34                 in format (fromInt (!numLinks) / fromInt (!numPeeks),
  35                            Format.fix (SOME 3))
  36                 end]]
  37    end
  38
  39 fun 'a newProperty () =
  40    let
  41       val {make, pred, peek = peekH} = H.new ()
  42       fun peek (T hs) =
  43          let
  44             fun loop (l, n) =
  45                let
  46                   fun update () =
  47                      ((numLinks := Int64.fromInt n + !numLinks
  48                        handle Overflow => Error.bug "PropertyList: numLinks overflow")
  49                       ; if n > !maxLength
  50                            then maxLength := n
  51                         else ())
  52                in case l of
  53                   [] => (update (); NONE)
  54                 | e :: l =>
  55                      case peekH e of
  56                         r as SOME _ => (update (); r)
  57                       | NONE => loop (l, n + 1)
  58                end
  59             val _ =
  60                numPeeks := 1 + !numPeeks
  61                handle Overflow => Error.bug "PropertyList: numPeeks overflow"
  62          in
  63             loop (!hs, 0)
  64          end
  65
  66       fun add (T hs, v: 'a): unit = hs := make v :: !hs
  67
  68       fun remove (T hs) = hs := List.remove (!hs, pred)
  69    in
  70       {add = add, peek = peek, remove = remove}
  71    end
  72
  73 end