[MLton-commit] r6933

[Vesa Karvonen]

Use a HashMap rather than an assoc list.

----------------------------------------------------------------------

U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml
U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb
U   mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.use

----------------------------------------------------------------------

Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml	2008-10-13 23:19:41 UTC (rev 6932)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/detail/server.sml	2008-10-14 06:44:22 UTC (rev 6933)
@@ -7,46 +7,45 @@
 structure Server :> SERVER = struct
    open SocketEvents Async Protocol
 
-   val entries :
-       {fingerprint : Fingerprint.t,
-        procedure : Token.t -> (Unit.t, Socket.active) monad} List.t Ref.t =
-       ref []
+   val entries : (Fingerprint.t,
+                  Token.t -> (Unit.t, Socket.active) monad) HashMap.t =
+       HashMap.new {eq = op =, hash = Word32.toWord o Fingerprint.toWord32}
 
-   fun find fingerprint =
-       List.find (eq fingerprint o #fingerprint) (!entries)
-
    val sendExn = send Exn.t
 
-   fun define (signature' as (dom, cod, _)) = let
+   fun define (signature' as (dom, cod, name)) = let
       val fingerprint = Fingerprint.make signature'
       val recvDom = recv dom
       val sendCod = send cod
       open Reply
    in
       fn f =>
-         (push entries)
-          {fingerprint = fingerprint,
-           procedure = fn token =>
-            recvDom >>= (fn x =>
-             try (fn () => f x,
-                  fn y =>
-                     send (RESULT token) >>= (fn () =>
-                     sendCod y),
-                  fn e =>
-                     send (EXN token) >>= (fn () =>
-                     sendExn e)))}
+         case HashMap.find entries fingerprint
+          of SOME _ => fails ["fingerprint of ", name, " already in use"]
+           | NONE =>
+             (HashMap.insert entries)
+              (fingerprint,
+               fn token =>
+                  recvDom >>= (fn x =>
+                  try (fn () => f x,
+                       fn y =>
+                          send (RESULT token) >>= (fn () =>
+                          sendCod y),
+                       fn e =>
+                          send (EXN token) >>= (fn () =>
+                          sendExn e))))
    end
 
    fun serve () =
        Request.recv >>= (fn req =>
        case req
-        of Request.CALL {token = token, fingerprint = fingerprint} =>
-           case find fingerprint
+        of Request.CALL {token, fingerprint} =>
+           case HashMap.find entries fingerprint
             of NONE =>
                skip >>= (fn () =>
                Reply.send (Reply.UNKNOWN token) >>=
                serve)
-             | SOME {procedure, ...} =>
+             | SOME procedure =>
                procedure token >>= serve)
 
    fun run {port, accept=filter} = let

Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb	2008-10-13 23:19:41 UTC (rev 6932)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.mlb	2008-10-14 06:44:22 UTC (rev 6933)
@@ -9,6 +9,7 @@
    $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
    $(MLTON_LIB)/com/ssh/async/unstable/lib.mlb
    $(MLTON_LIB)/com/ssh/async/unstable/example/poll-loop/lib.mlb
+   $(MLTON_LIB)/org/mlton/vesak/ds/unstable/lib.mlb
 
    $(APPLICATION)/generic.mlb
 

Modified: mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.use
===================================================================
--- mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.use	2008-10-13 23:19:41 UTC (rev 6932)
+++ mltonlib/trunk/org/mlton/vesak/rpc-lib/unstable/lib-server.use	2008-10-14 06:44:22 UTC (rev 6933)
@@ -8,6 +8,7 @@
      "${MLTON_LIB}/com/ssh/generic/unstable/lib.use",
      "${MLTON_LIB}/com/ssh/async/unstable/lib.use",
      "${MLTON_LIB}/com/ssh/async/unstable/example/poll-loop/lib.use",
+     "${MLTON_LIB}/org/mlton/vesak/ds/unstable/lib.use",
      "${APPLICATION}/generic.use",
      "detail/protocol.use",
      "public/server/server.sig",