1. james woodyatt
  2. oni

Commits

jhwoodyatt  committed 432e3e1

Submit cf-0.1 release.

  • Participants
  • Parent commits dabf4ad
  • Branches default

Comments (0)

Files changed (3)

File cf/cf_flow.mli

View file
 (*---------------------------------------------------------------------------*
   INTERFACE  cf_flow.mli
 
-  Copyright (c) 2002, James H. Woodyatt
+  Copyright (c) 2002-2004, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
     val last: ('i Cf_seq.t option, 'o) t -> 'o Cf_seq.t
 end
 
+(** {6 Monad Functions} *)
+
+(** The continuation monad that returns a value obtained from the flow produced
+    by its evaluation.
+*)
+val readC: (('i, 'o) t, 'i) Cf_cmonad.t
+
+(** Use [writeC x] to compose a continuation monad that puts [x] into the
+    flow produced by evaluation and returns the unit value.
+*)
+val writeC: 'o -> (('i, 'o) t, unit) Cf_cmonad.t
+
+(** Use [evalC m] to evaluate the continuation monad [m], computing the
+    encapsulated flow.
+*)
+val evalC: (('i, 'o) t, unit) Cf_cmonad.t -> ('i, 'o) t
+
+(** The state-continuation monad that returns a value obtained from the flow
+    produced by its evaluation.
+*)
+val readSC: ('s, ('i, 'o) t, 'i) Cf_scmonad.t
+
+(** Use [writeSC x] to compose a state-continuation monad that puts [x] into
+    the flow produced by evaluation and returns the unit value.
+*)
+val writeSC: 'o -> ('s, ('i, 'o) t, unit) Cf_scmonad.t
+
+(** Use [evalSC m s] to evaluate the state-continuation monad [m] with the
+    initial state [s], computing the encapsulated flow.
+*)
+val evalSC: ('s, ('i, 'o) t, unit) Cf_scmonad.t -> 's -> ('i, 'o) t
+
 (*--- End of File [ cf_flow.mli ] ---*)

File cf/cf_gadget.ml

View file
 (*---------------------------------------------------------------------------*
   IMPLEMENTATION  cf_gadget.ml
 
-  Copyright (c) 2003, James H. Woodyatt
+  Copyright (c) 2003-2004, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
+(*
+module type X_tag = sig
+    val tag: string
+end
+
+module X_create(T: X_tag) = struct
+    let tag = Printf.sprintf "[%s] " T.tag
+
+    let printf fmt =
+        print_string tag;
+        Printf.printf fmt
+    
+    let sprintf (fmt : ('a, unit, string) format) =
+        Printf.sprintf (Obj.magic (tag ^ (Obj.magic fmt)))
+end
+
+module X = X_create(struct let tag = "Cf_gadget" end)
+*)
+
 module Int_map = Cf_rbtree.Create(Cf_ordered.Int_order)
 
 type ('i, 'o) process0_t =
     k:('i, 'o) kernel_t -> (('i, 'o) Cf_flow.t, unit) Cf_cmonad.t
 and ('i, 'o) gate0_t = {
-    g_id_: int;
-    g_ptr_: Obj.t Weak.t;
+    g_pin_: pin_t;
     g_bind_: (Obj.t -> ('i, 'o) process0_t);
 }
 and pin_t = {
     mutable k_gs_: ('i, 'o) gate0_t Cf_seq.t list;
     mutable k_mq_: Obj.t Queue.t Int_map.t;
     k_inq_: ('i -> ('i, 'o) process0_t) Queue.t;
-    k_rdyq_: ('i, 'o) process0_t Queue.t;
+    k_rdyq_: ('i, 'o) process0_t Lazy.t Queue.t;
 }
 
-type ('s, 'i, 'o) process_t =
-    ('s -> ('i, 'o) process0_t) -> 's -> ('i, 'o) process0_t
-type ('s, 'i, 'o) gate_t = 's -> ('i, 'o) gate0_t
-type ('s, 'i, 'o, 'a) t = (('s, 'i, 'o) process_t, 'a) Cf_cmonad.t
-
 module Pin_order = struct
     type t = pin_t
     let compare a b = b.x_id_ - a.x_id_
         if z <> Cf_seq.Z then
             k.k_gs_ <- (Lazy.lazy_from_val z) :: k.k_gs_
     | Cf_seq.P (hd, tl) ->
-        let id = hd.g_id_ in
+        let id = hd.g_pin_.x_id_ in
         match
             try Some (Int_map.search id k.k_mq_) with Not_found -> None
         with
         | None ->
-            if Weak.check hd.g_ptr_ 0 then Queue.add hd aq;
+            if Weak.check hd.g_pin_.x_ptr_ 0 then Queue.add hd aq;
             matchGate1_ ~k ~aq tl
         | Some q ->
             match
             | None ->
                 assert (not true)
             | Some obj ->
-                if Queue.is_empty q then
-                    k.k_mq_ <- Int_map.delete id k.k_mq_;
-                Queue.add (hd.g_bind_ obj) k.k_rdyq_
+                if Queue.is_empty q then k.k_mq_ <- Int_map.delete id k.k_mq_;
+                Queue.add (lazy (hd.g_bind_ obj)) k.k_rdyq_
 
 let rec matchGate0_ ~k = function
     | [] ->
         try Some (Queue.take k.k_rdyq_) with Queue.Empty -> None
     with
     | Some p ->
-        p ~k c
+        Lazy.force p ~k c
     | None ->
         let gs = k.k_gs_ in
         k.k_gs_ <- [];
         else
             scheduler_ ~k c
 
-let return a c = c a
-module Op = struct let ( >>= ) m f x = m (fun a -> f a x) end
+class ['a, 'i, 'o] connector x =
+    object
+        method pin = x
+        method check = Weak.check x.x_ptr_ 0
+        method id = string_of_int x.x_id_
+    end
+
+open Cf_cmonad.Op
+
+type ('s, 'i, 'o) process_t =
+    ('s -> ('i, 'o) process0_t) -> 's -> ('i, 'o) process0_t
+type ('s, 'i, 'o) gate_t = ('s -> ('i, 'o) gate0_t) Cf_seq.t
+
+type ('s, 'i, 'o, 'a) guard_t = (('s, 'i, 'o) gate_t, 'a) Cf_cmonad.t
+type ('s, 'i, 'o, 'a) t = (('s, 'i, 'o) process_t, 'a) Cf_cmonad.t
 
 let downX1_ () _ _ = scheduler_
 let downX2_ _ = scheduler_
     m downX1_ downX2_ s ~k f
 
 let start m s0 f c1 s1 ~k =
-    Queue.add (m downX1_ downX2_ s0) k.k_rdyq_;
+    Queue.add (lazy (m downX1_ downX2_ s0)) k.k_rdyq_;
     f () c1 s1 ~k
 
 let wire f c s ~k =
     let ch = { e_rx_ = rx; e_tx_ = tx } in
     f ch c s ~k
 
-let zguard z _ c s ~k =
-    k.k_gs_ <- (Cf_seq.map (fun g -> g s) z) :: k.k_gs_;
+let guard m _ _ s ~k =
+    k.k_gs_ <- (Cf_seq.map (fun g -> g s) (Cf_seq.evalC m)) :: k.k_gs_;
     scheduler_ ~k
 
-let guard s = zguard (Cf_seq.of_list s)
-
 class ['a, 'i, 'o] rx ch =
     let x = ch.e_rx_ in
     object
-        method pin = x
+        inherit ['a, 'i, 'o] connector x
         
         method get:
-            's. ('a -> ('s, 'i, 'o, unit) t) -> ('s, 'i, 'o) gate_t =
-            fun f s ->
-                let g obj = f obj downX1_ downX2_ s in
-                { g_id_ = x.x_id_; g_ptr_ = x.x_ptr_; g_bind_ = Obj.magic g }
+            's. ('a -> ('s, 'i, 'o, unit) t) -> ('s, 'i, 'o, unit) guard_t =
+            fun f ->
+                Cf_seq.writeC begin fun s ->
+                    let g obj = f obj downX1_ downX2_ s in
+                    { g_pin_ = x; g_bind_ = Obj.magic g }
+                end
     end
 
 class ['a, 'i, 'o] tx ch =
     let x = ch.e_tx_ in
     object
-        method pin = x
+        inherit ['a, 'i, 'o] connector x
         
         method put:
             's. 'a -> ('s, 'i, 'o, unit) t =
                         Queue.add obj q;
                         k.k_mq_ <- Int_map.replace (x.x_id_, q) k.k_mq_
                 end
-                else
+                else begin
                     k.k_mq_ <- Int_map.delete x.x_id_ k.k_mq_;
-                Queue.add (f () c1 s) k.k_rdyq_;
-                scheduler_ ~k c0
+                end;
+                let q = k.k_rdyq_ in
+                if Queue.is_empty q then
+                    f () c1 s ~k c0
+                else begin
+                    Queue.add (lazy (f () c1 s)) k.k_rdyq_;
+                    Lazy.force (Queue.take k.k_rdyq_) ~k c0
+                end
     end
 
 type ('a, 'i, 'o) simplex_t = ('a, 'i, 'o) rx * ('a, 'i, 'o) tx
     Queue.add (fun i -> f i g s) k.k_inq_;
     scheduler_ ~k c
 
-let write o c =
+let write o =
     let m f = lazy (Cf_flow.P (o, f ())) in
-    fun c1 s ~k c0 -> m (fun () -> c () c1 s ~k c0)
+    fun c c1 s ~k c0 -> m (fun () -> c () c1 s ~k c0)
 
 let load p c s = (p s) c s
 let store s f c _ = f () c s
     begin
         simplex >>= fun (rx1, tx1) ->
         simplex >>= fun (rx2, tx2) ->
-        return ((rx1, tx2), (rx2, tx1))
+        Cf_cmonad.return ((rx1, tx2), (rx2, tx1))
     end f
 
 let wrap x y =
     let rec loop w =
         match Lazy.force w with
         | Cf_flow.Z ->
-            return ()
+            Cf_cmonad.return ()
         | Cf_flow.P (hd, tl) ->
             y#put hd >>= fun () ->
             loop tl
         | Cf_flow.Q f ->
-            guard [ x#get (fun obj -> loop (lazy (f obj))) ]
+            guard (x#get (fun obj -> loop (lazy (f obj))))
     in
     fun w ->
         start (loop w) ()

File cf/cf_gadget.mli

View file
 (*---------------------------------------------------------------------------*
   INTERFACE  cf_gadget.mli
 
-  Copyright (c) 2003, James H. Woodyatt
+  Copyright (c) 2003-2004, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
 *)
 type ('s, 'i, 'o) process_t
 
-(** A continuation monad parameterized process type. *)
-type ('s, 'i, 'o, 'a) t = (('s, 'i, 'o) process_t, 'a) Cf_cmonad.t
-
-(** A gate for receiving messages in a process of type [('s, 'i, 'o)
-    process_t].
+(** A gate for receiving messages in a process of type [('s, 'i, 'o) process_t]
+    using the [guard] function.
 *)
 type ('s, 'i, 'o) gate_t
 
+(** A guard for receiving a message from one or more sources. *)
+type ('s, 'i, 'o, 'a) guard_t = (('s, 'i, 'o) gate_t, 'a) Cf_cmonad.t
+
+(** A continuation monad parameterized by process type. *)
+type ('s, 'i, 'o, 'a) t = (('s, 'i, 'o) process_t, 'a) Cf_cmonad.t
+
 (** An object capable of delivering messages of type ['a] from a sender to a
-    [('s, 'i, 'o) gate_t] object.
+    a receiver in a [('s, 'i, 'o) process_t] object.
 *)
 type ('a, 'i, 'o) wire_t
 
 *)
 val start: ('s0, 'i, 'o, unit) t -> 's0 -> ('s1, 'i, 'o, unit) t
 
-(** Use [zguard z] to receive the next message from a gate in the sequence [z].
-    The sequence is evaluated until a gate is found with a message to deliver.
-*)
-val zguard: ('s, 'i, 'o) gate_t Cf_seq.t -> ('s, 'i, 'o, unit) t
-
-(** Use [guard s] to receive the next message from a gate in the list [s].  The
-    first gate in the list with a message to deliver is the one that receives
-    its message.
-*)
-val guard: ('s, 'i, 'o) gate_t list -> ('s, 'i, 'o, unit) t
+(** Use [guard m] to receive the next message guard by [m]. *)
+val guard: ('s, 'i, 'o, unit) guard_t -> ('s, 'i, 'o, unit) t
 
 (** Bind [wire] to create a new wire object for sending messages of type ['a].
 *)
 
 (** {6 Classes} *)
 
+(** The class type of connector objects. *)
+class type ['a, 'i, 'o] connector =
+    object
+        (** Returns the pin associated with the object. *)
+        method pin: pin_t
+        
+        (** Returns [true] if the other end of the wire has not yet been
+            reclaimed by the garbage collector.
+        *)
+        method check: bool
+        
+        (** Returns a string representation of the wire end identifier. *)
+        method id: string
+    end
+
 (** The class of receiver objects. *)
 class ['a, 'i, 'o] rx:
     ('a, 'i, 'o) wire_t -> (** A wire carrying messages of type ['a]. *)
     object
-        (** Returns the pin associated with the object. *)
-        method pin: pin_t
+        inherit ['a, 'i, 'o] connector
         
-        (** Use [rx#get f] to produce a gate that receives a message on the
+        (** Use [rx#get f] to produce a guard that receives a message on the
             associated wire by applying the function [f] to it.
         *)
-        method get: 's. ('a -> ('s, 'i, 'o, unit) t) -> ('s, 'i, 'o) gate_t
+        method get:
+            's. ('a -> ('s, 'i, 'o, unit) t) ->
+            ('s, 'i, 'o, unit) guard_t
     end
 
-class ['a, 'i, 'o] tx: (** The class of transmitter objects. *)
+(** The class of transmitter objects. *)
+class ['a, 'i, 'o] tx:
     ('a, 'i, 'o) wire_t -> (** A wire carrying messages of type ['a]. *)
     object
-        (** Returns the pin associated with the object. *)
-        method pin: pin_t
+        inherit ['a, 'i, 'o] connector
         
         (** Use [tx#put obj] to schedule the message obj for deliver on the
             associated wire.