[MLton-commit] r6194

Vesa Karvonen vesak at mlton.org
Wed Nov 21 09:02:58 PST 2007


One way to write Erlang in CML.
----------------------------------------------------------------------

A   mltonlib/trunk/org/mlton/vesak/tech/cermlang/
A   mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/
A   mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/echo.mlb
A   mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/echo.sml
A   mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/
A   mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/cermlang.sig
A   mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/cermlang.sml
A   mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/infixes.sml
A   mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/lib.mlb

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


Property changes on: mltonlib/trunk/org/mlton/vesak/tech/cermlang
___________________________________________________________________
Name: svn:ignore
   + 


Added: mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/echo.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/echo.mlb	2007-11-21 12:22:34 UTC (rev 6193)
+++ mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/echo.mlb	2007-11-21 17:02:57 UTC (rev 6194)
@@ -0,0 +1,15 @@
+(* Copyright (C) 2007 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+   $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+   ../lib/lib.mlb
+
+   ann "nonexhaustiveExnMatch ignore" in
+      echo.sml
+   end
+in
+end


Property changes on: mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/echo.mlb
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/echo.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/echo.sml	2007-11-21 12:22:34 UTC (rev 6193)
+++ mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/echo.sml	2007-11-21 17:02:57 UTC (rev 6194)
@@ -0,0 +1,27 @@
+(* Copyright (C) 2007 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+open CerMLang
+
+(* This example is roughly a transliteration of "An Echo process" example
+ * from [http://www.erlang.org/course/concurrent_programming.html#echo An
+ * Erlang Course].
+ *)
+
+exception Echo of Proc.t * String.t
+exception Stop
+
+fun echo () =
+    recv (fn Stop        => (fn () => ())
+           | Echo (s, m) => (fn () => (s <- Echo (self (), m) ; echo ())))
+
+val () = start (fn () => let
+   val echo = spawn echo
+in
+   echo <- Echo (self (), "Hi!")
+ ; recv (fn Echo (_, msg) => (fn () => println ("Echo says: "^msg)))
+ ; echo <- Stop
+end)


Property changes on: mltonlib/trunk/org/mlton/vesak/tech/cermlang/example/echo.sml
___________________________________________________________________
Name: svn:eol-style
   + native


Property changes on: mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib
___________________________________________________________________
Name: svn:ignore
   + generated


Added: mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/cermlang.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/cermlang.sig	2007-11-21 12:22:34 UTC (rev 6193)
+++ mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/cermlang.sig	2007-11-21 17:02:57 UTC (rev 6194)
@@ -0,0 +1,25 @@
+(* Copyright (C) 2007 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+signature CERMLANG = sig
+   structure Proc : sig
+      type t
+   end
+
+   structure Msg : sig
+      type t = Exn.t
+   end
+
+   exception Time
+
+   val start : Unit.t Effect.t Effect.t
+
+   val spawn : Unit.t Effect.t -> Proc.t
+   val self : Proc.t Thunk.t
+   val recvIn : Time.time Option.t -> (Msg.t -> 'a Thunk.t) -> 'a
+   val recv : (Msg.t -> 'a Thunk.t) -> 'a
+   val <- : (Proc.t * Msg.t) Effect.t
+end


Property changes on: mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/cermlang.sig
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/cermlang.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/cermlang.sml	2007-11-21 12:22:34 UTC (rev 6193)
+++ mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/cermlang.sml	2007-11-21 17:02:57 UTC (rev 6194)
@@ -0,0 +1,58 @@
+(* Copyright (C) 2007 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure CerMLang :> CERMLANG = struct
+   structure Msg = Exn
+
+   structure Proc = struct
+      datatype t = IN of {tid : CML.thread_id,
+                          msgs : {mbox : Msg.t Mailbox.mbox,
+                                  more : Msg.t List.t Ref.t}}
+      local
+         val {getMsgs, setMsgs} =
+             case CML.newThreadProp (fn () => fail "thread prop")
+              of {getFn, setFn, ...} => {getMsgs = getFn, setMsgs = setFn}
+      in
+         fun current () = IN {tid = CML.getTid (), msgs = getMsgs ()}
+         fun new () = setMsgs {mbox = Mailbox.mailbox (), more = ref []}
+         fun msgsOf (IN r) = #msgs r
+         val msgs = getMsgs
+      end
+   end
+
+   exception Time = Time.Time
+
+   fun start ef = ignore (RunCML.doit (ef o Proc.new, NONE))
+
+   fun spawn ef = let
+      val i = SyncVar.iVar ()
+   in
+      ignore (CML.spawn (fn () => (Proc.new ()
+                                 ; SyncVar.iPut (i, Proc.current ())
+                                 ; ef ())))
+    ; SyncVar.iGet i
+   end
+   val self = Proc.current
+   fun recv handler = let
+      val {mbox, more} = Proc.msgs ()
+      fun lpRecv tried =
+          case Mailbox.recv mbox
+           of m => try (fn () => handler m,
+                        fn th => (more := rev tried ; th ()),
+                        fn Match => lpRecv (m::tried)
+                         | other => (more := rev tried ; raise other))
+      fun lpMsgs tried =
+       fn []    => lpRecv tried
+        | m::ms => try (fn () => handler m,
+                        fn th => (more := ms @ tried ; th ()),
+                        fn Match => lpMsgs (m::tried) ms
+                         | other => (more := ms @ tried ; raise other))
+   in
+      lpMsgs [] (!more before more := [])
+   end
+   val recvIn = undefined
+   fun t <- m = Mailbox.send (#mbox (Proc.msgsOf t), m)
+end


Property changes on: mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/cermlang.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/infixes.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/infixes.sml	2007-11-21 12:22:34 UTC (rev 6193)
+++ mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/infixes.sml	2007-11-21 17:02:57 UTC (rev 6194)
@@ -0,0 +1,7 @@
+(* Copyright (C) 2007 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+infix <-


Property changes on: mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/infixes.sml
___________________________________________________________________
Name: svn:eol-style
   + native

Added: mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/lib.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/lib.mlb	2007-11-21 12:22:34 UTC (rev 6193)
+++ mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/lib.mlb	2007-11-21 17:02:57 UTC (rev 6194)
@@ -0,0 +1,20 @@
+(* Copyright (C) 2007 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+   $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+   $(SML_LIB)/cml/cml.mlb
+in
+   ann
+      "forceUsed"
+      "warnUnused true"
+      "sequenceNonUnit warn"
+   in
+      infixes.sml
+      cermlang.sig
+      cermlang.sml
+   end
+end


Property changes on: mltonlib/trunk/org/mlton/vesak/tech/cermlang/lib/lib.mlb
___________________________________________________________________
Name: svn:eol-style
   + native




More information about the MLton-commit mailing list