[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