Commits

Anonymous committed d8dac4b

Submit of cf-0.3 release.

Comments (0)

Files changed (19)

 (*---------------------------------------------------------------------------*
-  INTERFACE  cf_gadget.mli
+  INTERFACE  cf_nflow.mli
 
-  Copyright (c) 2003-2004, James H. Woodyatt
+  Copyright (c) 2004, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
   OF THE POSSIBILITY OF SUCH DAMAGE. 
  *---------------------------------------------------------------------------*)
 
+
 (** Monadic composition of complex stream processors.  An experimental
     interface for constructing highly interactive functional systems in a
     single thread of control.
         {- {i write}: write a new value to the external output.}
     }
     
-    A wire is logically composed of a "rx" pin and a "tx" pin.  While a "pin"
-    is an abstract type with no parameters, a "wire" is parameterized by the
-    type of message it can carry.  A pair of classes are provided to represent
-    the receiver and the transmitter on a wire.  Objects of the [rx] class
-    define a [get] method for creating a "gate" that can receive a message.
-    Objects of the [tx] class define a [put] method for transmitting a message.
-    Both objects can be constructed with a wire object, and a convenience
-    operators are defined for creating a new wire and construction a pair of
-    associated [rx] and [tx] objects.
+    A wire is logically composed of a receiver and a transmitter, with weak
+    mutual references between them.  When either end of the wire is reclaimed
+    by the memory allocator, the other end is automatically rendered into a
+    null wire, i.e. receivers never get messages and transmitters put messages
+    by discarding them.
+    
+    A pair of classes are provided to represent the receiver and the
+    transmitter on a wire.  Objects of the [rx] class define a [get] method for
+    creating a "gate" that can receive a message.  Objects of the [tx] class
+    define a [put] method for transmitting a message.  Both objects can be
+    constructed with a wire object, and a convenience operators are defined for
+    creating a new wire and construction a pair of associated [rx] and [tx]
+    objects.
     
     Each process contains an encapsulated state, initialized to a value when
     the process is started.  As a process receives and transmits messages, it
 
 (** {6 Types} *)
 
-(** An abstract process type for gadgets that encapsulate state and evaluate to
-    objects of type {!Cf_flow.t}.
+(** An functionally compositional unit of work in a gadget.  It encapsulates
+    the state-continuation monad for a work loop.
 *)
-type ('s, 'i, 'o) process_t
+type ('s, 'i, 'o) work_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
 
+(** An object capable of delivering messages of type ['x] from a sender to a
+    a receiver in a [('s, 'i, 'o) work_t] continuation.
+*)
+type ('x, 'i, 'o) wire_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
-    a receiver in a [('s, 'i, 'o) process_t] object.
-*)
-type ('a, 'i, 'o) wire_t
-
-(** The abstract type representing an endopint of a wire. *)
-type pin_t
-
-(** {6 Modules } *)
-
-(** The module defining a red-black binary tree that use pins for the key. *)
-module Pin_map: Cf_map.T with type Key.t = pin_t
-
-(** The module defining a set of pins. *)
-module Pin_set: Cf_set.T with type Element.t = pin_t
+type ('s, 'i, 'o, 'a) t = (('s, 'i, 'o) work_t, 'a) Cf_cmonad.t
 
 (** {6 Functions} *)
 
 (** 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].
+(** Bind [wire] to create a new wire object for sending messages of type ['x].
 *)
-val wire: ('s, 'i, 'o, ('a, 'i, 'o) wire_t) t
+val wire: ('s, 'i, 'o, ('x, 'i, 'o) wire_t) t
 
 (** Use [null] to construct a [rx] object that produces gates that never
     receive any messages, and a [tx] object that discards every message
     transmitted without deliver it.  This object can be useful for default
     arguments to some gadget functions.
 *)
-val null: ('a, 'i, 'o) wire_t
+val null: ('x, 'i, 'o) wire_t
 
 (** Bind [read] to get the next input value from the external stream. *)
 val read: ('s, 'i, 'o, 'i) t
 (** {6 Classes} *)
 
 (** The class type of connector objects. *)
-class type ['a, 'i, 'o] connector =
+class type 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.
         *)
     end
 
 (** The class of receiver objects. *)
-class ['a, 'i, 'o] rx:
-    ('a, 'i, 'o) wire_t -> (** A wire carrying messages of type ['a]. *)
+class ['x, 'i, 'o] rx:
+    ('x, 'i, 'o) wire_t -> (** A wire carrying messages of type ['x]. *)
     object
-        inherit ['a, 'i, 'o] connector
+        inherit connector
         
         (** 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, unit) guard_t
+            's. ('x -> ('s, 'i, 'o, unit) t) -> ('s, 'i, 'o, unit) guard_t
     end
 
 (** The class of transmitter objects. *)
-class ['a, 'i, 'o] tx:
-    ('a, 'i, 'o) wire_t -> (** A wire carrying messages of type ['a]. *)
+class ['x, 'i, 'o] tx:
+    ('x, 'i, 'o) wire_t -> (** A wire carrying messages of type ['x]. *)
     object
-        inherit ['a, 'i, 'o] connector
+        inherit connector
         
         (** Use [tx#put obj] to schedule the message obj for deliver on the
             associated wire.
         *)
-        method put: 's. 'a -> ('s, 'i, 'o, unit) t
+        method put: 's. 'x -> ('s, 'i, 'o, unit) t
     end
 
 (** {6 Miscellaneous} *)
 
 (** A convenience type combining the [rx] and [tx] objects of a wire. *)
-type ('a, 'i, 'o) simplex_t = ('a, 'i, 'o) rx * ('a, 'i, 'o) tx
+type ('x, 'i, 'o) simplex_t = ('x, 'i, 'o) rx * ('x, 'i, 'o) tx
 
 (** Use [fsimplex ~f] to construct a new wire and apply it to the constructor
     function [f] to pass along a new matching pair of [rx] and [tx] objects.
 *)
 val fsimplex:
-    f:(('a, 'i, 'o) wire_t -> ('a, 'i, 'o) #rx * ('a, 'i, 'o) #tx) ->
-    ('s, 'i, 'o, ('a, 'i, 'o) rx * ('a, 'i, 'o) tx) t
+    f:(('x, 'i, 'o) wire_t -> ('x, 'i, 'o) #rx * ('x, 'i, 'o) #tx) ->
+    ('s, 'i, 'o, ('x, 'i, 'o) rx * ('x, 'i, 'o) tx) t
 
 (** Use [simplex] to construct a new maching pair of [rx] and [tx] objects.*)
-val simplex: ('s, 'i, 'o, ('a, 'i, 'o) rx * ('a, 'i, 'o) tx) t
+val simplex: ('s, 'i, 'o, ('x, 'i, 'o) rx * ('x, 'i, 'o) tx) t
 
 (** A convenience type combining two wires into a pair of [rx] and [tx]
     tuples, one tuple for each end of a duplex communication.  Each tuple is
     composed of the [rx] and the [tx] objects to use on one end of the
     communication.
 *)
-type ('a, 'b, 'i, 'o) duplex_t =
-    (('a, 'i, 'o) rx * ('b, 'i, 'o) tx) * (('b, 'i, 'o) rx * ('a, 'i, 'o) tx)
+type ('x, 'y, 'i, 'o) duplex_t =
+    (('x, 'i, 'o) rx * ('y, 'i, 'o) tx) * (('y, 'i, 'o) rx * ('x, 'i, 'o) tx)
 
 (** Use [duplex] to construct a new duplex communication channel, composed of
     two wires each in opposite flowl.
 *)
-val duplex: ('s, 'i, 'o, ('a, 'b, 'i, 'o) duplex_t) t
+val duplex: ('s, 'i, 'o, ('x, 'y, 'i, 'o) duplex_t) t
 
 (** Use [wrap rx tx w] to start a new process that wraps the flow [w], so that
     it reads output from the flow (copying it to [tx] object) and writes input
     ('x, 'i, 'o) #rx -> ('y, 'i, 'o) #tx -> ('x, 'y) Cf_flow.t ->
     ('s, 'i, 'o, unit) t
 
-(*--- End of File [ cf_gadget.mli ] ---*)
+(*--- End of File [ cf_nflow.mli ] ---*)

cf/cf_ip4_addr_p.c

     resultVal = Val_int(0);
     if (result > 0) {
         resultVal = alloc_small(1, 0);
-        Field(resultVal, 0) = cf_ip4_addr_alloc(&addr);
+        Store_field(resultVal, 0, cf_ip4_addr_alloc(&addr));
     }
     
     CAMLreturn(resultVal);

cf/cf_ip6_addr_p.c

 static value cf_ip6_addr_alloc_constructor_0(int n)
 {
     value v = alloc_small(1, 0);
-    Field(v, 0) = Int_val(n);
+    Store_field(v, 0, Int_val(n));
     return v;
 }
 
 CAMLprim value cf_ip6_addr_to_multicast_components(value addrVal)
 {
     CAMLparam1(addrVal);
-    CAMLlocal4(resultVal, scopeVal, flagListVal, groupIdVal);
+    CAMLlocal5(resultVal, scopeVal, flagListVal, groupIdVal, hdVal);
+    CAMLlocal1(consVal);
     
     const struct in6_addr* addrPtr = Cf_ip6_addr_val(addrVal);
     struct in6_addr groupId;
     flagListVal = Val_int(0);
     for (i = 0; i < 4; ++i) {
         if (word & (0x100000 << i)) {
-            CAMLlocal1(hdVal);
             hdVal = alloc_small(2, 0);
             if (i == 0)
-                Field(hdVal, 0) = Val_int(0);
+                Store_field(hdVal, 0, Val_int(0));
             else {
-                CAMLlocal1(consVal);
                 consVal = alloc_small(1, 0);
-                Field(consVal, 0) = Val_int(i);
-                Field(hdVal, 0) = consVal;
+                Store_field(consVal, 0, Val_int(i));
+                Store_field(hdVal, 0, consVal);
             }
-            Field(hdVal, 1) = flagListVal;
+            Store_field(hdVal, 1, flagListVal);
             flagListVal = hdVal;
         }
     }
     groupIdVal = cf_ip6_addr_alloc(&groupId);
     
     resultVal = alloc_small(3, 0);
-    Field(resultVal, 0) = scopeVal;
-    Field(resultVal, 1) = flagListVal;
-    Field(resultVal, 2) = groupIdVal;
+    Store_field(resultVal, 0, scopeVal);
+    Store_field(resultVal, 1, flagListVal);
+    Store_field(resultVal, 2, groupIdVal);
         
     CAMLreturn(resultVal);
 }
    (value scopeVal, value flagListVal, value groupIdVal)
 {
     CAMLparam3(scopeVal, flagListVal, groupIdVal);
+    CAMLlocal2(flagVal, consVal);
     
     struct in6_addr addr;
     u_int8_t byte;
     addr.s6_addr[0] = 0xFF;
 
     byte = 0;
-    while (Is_block(flagListVal)) {
-        CAMLlocal1(flagVal);
-        
+    while (Is_block(flagListVal)) {        
         flagVal = Field(flagListVal, 0);
         if (Is_block(flagVal)) {
-            CAMLlocal1(consVal);
             int unassigned;
             
             consVal = Field(0, flagVal);
     resultVal = Val_int(0);
     if (result > 0) {
         resultVal = alloc_small(1, 0);
-        Field(resultVal, 0) = cf_ip6_addr_alloc(&addr);
+        Store_field(resultVal, 0, cf_ip6_addr_alloc(&addr));
     }
     
     CAMLreturn(resultVal);

cf/cf_ip6_proto_p.c

     addrVal = cf_ip6_addr_alloc(&sin6Ptr->sin6_addr);
     
     resultVal = alloc_small(2, 0);
-    Field(resultVal, 0) = addrVal;
-    Field(resultVal, 1) = Val_int(ntohs(sin6Ptr->sin6_port));
+    Store_field(resultVal, 0, addrVal);
+    Store_field(resultVal, 1, Val_int(ntohs(sin6Ptr->sin6_port)));
     
     CAMLreturn(resultVal);
 }
     multiaddrVal = cf_ip6_addr_alloc(&optval.ipv6mr_multiaddr);
 
     resultVal = alloc_small(2, 0);
-    Field(resultVal, 0) = multiaddrVal;
-    Field(resultVal, 0) = Val_int(optval.ipv6mr_interface);
+    Store_field(resultVal, 0, multiaddrVal);
+    Store_field(resultVal, 1, Val_int(optval.ipv6mr_interface));
 
     CAMLreturn(resultVal);
 }
+(*---------------------------------------------------------------------------*
+  IMPLEMENTATION  cf_journal.ml
+
+  Copyright (c) 2004, James H. Woodyatt
+  All rights reserved.
+
+  Redistribution and use in source and binary forms, with or without
+  modification, are permitted provided that the following conditions
+  are met:
+
+    Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+    Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution
+
+  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+  OF THE POSSIBILITY OF SUCH DAMAGE. 
+ *---------------------------------------------------------------------------*)
+
+(*
+let nullf_ fmt =
+    let fmt = string_of_format fmt in
+    let len = String.length fmt in
+    let rec eatfmt i =
+        if i >= len then
+            Obj.magic ()
+        else
+            match String.unsafe_get fmt i with
+            | '%' -> Printf.scan_format fmt i sF aF tF fF
+            | ch -> eatfmt (succ i)
+    and sF _ i = eatfmt i
+    and aF _ _ i = eatfmt i
+    and tF _ i = eatfmt i
+    and fF i = eatfmt i
+    in
+    eatfmt 0
+*)
+
+module type T = sig
+    module Priority: Cf_ordered.Total_T
+    
+    class virtual ['level] prioritizer:
+        object
+            method virtual code: 'level -> Priority.t
+            method virtual tag: 'level -> string
+        end
+
+    class ['level] event:
+        'level #prioritizer -> 'level -> string ->
+        object
+            method prioritizer: 'level prioritizer
+            method level: 'level
+            method message: string
+        end
+    
+    class virtual ['event] archiver:
+        object
+            constraint 'event = 'level #event            
+            method virtual emit: 'event -> unit
+        end
+
+    class virtual ['archiver] agent:
+        'level #prioritizer -> 'level -> 'archiver list ->
+        object
+            constraint 'event = 'level #event
+            constraint 'archiver = 'event #archiver
+
+            val mutable archivers_: 'archiver list
+            val mutable limit_: Priority.t            
+
+            method virtual private event_: 'level -> string -> 'event
+
+            method setlimit: 'level -> unit
+            method enabled: 'level -> bool
+            
+            method private put_:
+                'a 'b. 'level -> ('event -> 'b) ->
+                ('a, unit, string, 'b) format4 -> 'a
+        end
+end
+
+module Create(P: Cf_ordered.Total_T) : (T with module Priority = P) = struct
+    module Priority = P
+    
+    class virtual ['level] prioritizer =
+        object
+            method virtual code: 'level -> Priority.t
+            method virtual tag: 'level -> string
+        end
+
+    class ['level] event prioritizer level message =
+        let prioritizer = (prioritizer :> 'level prioritizer) in
+        object(_:'event)
+            method prioritizer = prioritizer
+            method level: 'level = level
+            method message: string = message
+        end
+    
+    class virtual ['event] archiver =
+        object
+            constraint 'event = 'level #event            
+            method virtual emit: 'event -> unit
+        end
+    
+    class virtual ['archiver] agent prioritizer limit archivers =
+        let prioritizer = (prioritizer :> 'level prioritizer) in
+        object(self:'self)
+            constraint 'event = 'level #event
+            constraint 'archiver = 'event #archiver
+
+            val mutable archivers_: 'archiver list = archivers
+            val mutable limit_ = prioritizer#code limit
+        
+            method virtual private event_: 'level -> string -> 'event
+
+            method setlimit limit = limit_ <- prioritizer#code limit
+            method enabled limit = prioritizer#code limit >= limit_
+            
+            method private put_:
+                'a 'b. 'level -> ('event -> 'b) ->
+                ('a, unit, string, 'b) format4 -> 'a
+                = fun level cont ->
+                    let f message =
+                        let e = self#event_ level message in
+                        if self#enabled level then
+                            List.iter (fun j -> j#emit e) archivers_;
+                        cont e
+                    in
+                    Printf.kprintf f
+        end
+end
+
+module Basic = struct
+    include Create(Cf_ordered.Int_order)
+
+    type invalid_t = [ `Invalid ]
+    type fail_t = [ `Fail ]
+    type error_t = [ `Error ]
+    type warn_t = [ `Warn ]
+    type info_t = [ `Info ]
+    type debug_t = [ `Debug ]
+    
+    type basic_t = [ invalid_t | fail_t | error_t | warn_t | info_t | debug_t ]
+    type enable_t = [ `None | `All ]
+    type level_t = [ basic_t | enable_t ]
+end
+
+class ['level] basic_prioritizer =
+    object
+        inherit ['level] Basic.prioritizer
+        constraint 'level = [> Basic.level_t ]
+        
+        method code = function
+            | `All -> max_int
+            | `Invalid -> 6000
+            | `Fail -> 5000
+            | `Error -> 4000
+            | `Warn -> 3000
+            | `Info -> 2000
+            | `Debug -> 1000
+            | `None -> min_int
+            | _ -> invalid_arg "Cf_journal: no code defined for priority!"
+        
+        method tag =
+            let invalid_ = "INVALID" in
+            let fail_ = "FAIL" in
+            let error_ = "ERROR" in
+            let warn_ = "WARN" in
+            let info_ = "INFO" in
+            let debug_ = "DEBUG" in
+            function
+            | `Invalid -> invalid_
+            | `Fail -> fail_
+            | `Error -> error_
+            | `Warn -> warn_
+            | `Info -> info_
+            | `Debug -> debug_
+            | _ -> invalid_arg "Cf_journal: no tag defined for priority!"
+    end
+
+class ['event] basic_channel_archiver channel =
+    object
+        constraint 'level = [> Basic.level_t ]
+        constraint 'event = 'level #Basic.event
+        inherit ['event] Basic.archiver
+        
+        method channel = channel
+        
+        method emit e =
+            let n = e#level in
+            let p = e#prioritizer in
+            if (p#code `Fail) - (p#code e#level) > 0 then begin
+                let tag = p#tag n in
+                let m = e#message in
+                Printf.fprintf channel "%s: %s\n" tag m;
+                flush channel
+            end
+    end
+
+class virtual ['archiver] basic_agent prioritizer limit archivers =
+    let prioritizer = (prioritizer :> 'level basic_prioritizer) in
+    object(self)
+        constraint 'level = [> Basic.level_t ]
+        constraint 'event = 'level #Basic.event
+        constraint 'archiver = 'event #Basic.archiver
+        inherit ['archiver] Basic.agent prioritizer limit archivers
+
+        method invalid: 'a 'b. ('a, unit, string, 'b) format4 -> 'a =
+            self#put_ `Invalid (fun x -> invalid_arg x#message)
+
+        method fail: 'a 'b. ('a, unit, string, 'b) format4 -> 'a =
+            self#put_ `Fail (fun x -> failwith x#message)
+        
+        method error: 'a. ('a, unit, string, unit) format4 -> 'a =
+            self#put_ `Error ignore
+        
+        method warn: 'a. ('a, unit, string, unit) format4 -> 'a =
+            self#put_ `Warn ignore
+        
+        method info: 'a. ('a, unit, string, unit) format4 -> 'a =
+            self#put_ `Info ignore
+        
+        method debug: 'a. ('a, unit, string, bool) format4 -> 'a =
+            self#put_ `Debug (fun _ -> true)
+    end
+
+let basic_prioritizer = new basic_prioritizer
+
+let basic_stdout_archiver =
+    new basic_channel_archiver Pervasives.stdout
+
+let basic_stderr_archiver =
+    new basic_channel_archiver Pervasives.stderr
+
+class basic_stdio_agent archiver =
+    object
+        inherit [Basic.level_t Basic.event basic_channel_archiver] basic_agent
+            basic_prioritizer `Warn [archiver]
+        
+        method private event_ = new Basic.event basic_prioritizer
+    end
+
+let stdout = new basic_stdio_agent basic_stdout_archiver
+let stderr = new basic_stdio_agent basic_stderr_archiver
+
+(*--- End of File [ cf_journal.ml ] ---*)

cf/cf_journal.mli

+(*---------------------------------------------------------------------------*
+  INTERFACE  cf_journal.mli
+
+  Copyright (c) 2004, James H. Woodyatt
+  All rights reserved.
+
+  Redistribution and use in source and binary forms, with or without
+  modification, are permitted provided that the following conditions
+  are met:
+
+    Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+    Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution
+
+  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+  OF THE POSSIBILITY OF SUCH DAMAGE. 
+ *---------------------------------------------------------------------------*)
+
+(** Diagnostic event journaling. *)
+
+(** {6 Overview} *)
+
+(** This module implements a lightweight foundation for diagnostic event
+    journaling, similar to the core Java classes in the {b Log4j} project from
+    the Apache Foundation.
+    
+    The core interface is functorial, and is intended for extensibility.  An
+    additional interface is provided for simplicity of use in the common case
+    of journaling diagnostic messages to [Pervasives.out_channel] objects, e.g
+    [stdout] and [stderr].
+*)
+
+(** {6 Functorial Interface} *)
+
+(** The type of the module produced the [Create(P: Cf_ordered.Total_T)]
+    functor defined below.
+*)
+
+module type T = sig
+
+    (** The module used to define the total order of priority levels. *)
+    module Priority: Cf_ordered.Total_T
+    
+    (** The base class for prioritizers.  Defines methods for converting
+        priority levels into 1) their corresponding code, and 2) their
+        corresponding message tag.
+    *)
+    class virtual ['level] prioritizer:
+        object
+            (** Use [p#code v] to convert the priority level [v] to a priority
+                code with the prioritizer [p].
+            *)
+            method virtual code: 'level -> Priority.t
+
+            (** Use [p#tag v] to convert the priority level [v] to a message
+                tag with the prioritizer [p].
+            *)
+            method virtual tag: 'level -> string
+        end
+
+    (** The minimal class of diagnostic events.  Use [new event p v m] to
+        construct an [event] object with the prioritizer [p], the priority
+        level [v], and the message [m].
+    *)
+    class ['level] event:
+        'level #prioritizer -> 'level -> string ->
+        object
+        
+            (** Returns the prioritizer used to construct the object. *)
+            method prioritizer: 'level prioritizer
+        
+            (** Returns the priority level used to construct the object. *)
+            method level: 'level
+        
+            (** Returns the message text used to construct the object. *)
+            method message: string
+        end
+    
+    (** The base class for event archivers.  Use [inherit archiver] to derive
+        a subclass that defines the [emit] method to archive a diagnostic
+        event into a journaling system.
+    *)
+    class virtual ['event] archiver:
+        object
+            constraint 'event = 'level #event
+            
+            (** Define the [emit] method in a subclass to archive diagnostic
+                events into a journaling system.
+            *)
+            method virtual emit: 'event -> unit
+        end
+
+    (** The base class for journaling agents.  Use [inherit agent p v s] to
+        derive a subclass that defines the private [event_] method to construct
+        an event object with a priority level and a message text using the
+        prioritizer [p].  Sets the initial priority code minimum to [v], and
+        the initial list of archivers to [s].
+    *)
+    class virtual ['archiver] agent:
+        'level #prioritizer -> 'level -> 'archiver list ->
+        object
+            constraint 'event = 'level #event
+            constraint 'archiver = 'event #archiver
+
+            (** The current list of archivers that journal events from
+                this agent. *)
+            val mutable archivers_: 'archiver list
+            
+            (** The minimum priority code for a diagnostic event to be
+                constructed and passed to the archivers.
+            *)
+            val mutable limit_: Priority.t            
+
+            (** Define the private [event_] method to construct an event object
+                with a priority level and a message text.
+            *)
+            method virtual private event_: 'level -> string -> 'event
+
+            (** Use [a#setlimit v] to set the minimum priority code to the
+                code corresponding to the priority level [v].
+            *)
+            method setlimit: 'level -> unit
+            
+            (** Use [a#enabled v] to test whether the priority code
+                corresponding to the priority level [v] is preceded in the
+                total order by the minimum priority code.
+            *)
+            method enabled: 'level -> bool
+            
+            (** Use this method in level-specific methods of the derived class
+                for constructing events and putting them to archivers.  Use
+                [super#put_ v c] to construct a function that takes a format
+                string (and arguments thereby specified) and, if [self#enabled
+                v] returns [true] then calls [self#event_ v m] (where [m] is
+                the message text given to the continuation provided to
+                [Printf.kprintf]), iterates on [archivers_] invoking the
+                [emit] method for each one with the constructed event, and
+                finally passing the event to the continuation [c].  The value
+                returned by [c] is returned by the method when invoked with
+                a format string (and associated arguments).
+            *)
+            method private put_:
+                'a 'b. 'level -> ('event -> 'b) ->
+                ('a, unit, string, 'b) format4 -> 'a
+        end
+end
+
+(** A functor that produces a module of type [T] that defines extensible
+    diagnostic event journaling with messages prioritized by codes in the total
+    order defined by the module [P].
+*)
+module Create(P: Cf_ordered.Total_T): T with module Priority = P
+
+(** {6 Basic Interface} *)
+
+(** A module defining basic diagnostic event journaling with a simple set of
+    priority levels associated to integer priority codes.
+*)
+module Basic: sig
+    
+    (** Event journaling with integer priority codes. *)
+    include T with type Priority.t = int
+
+    (** The priority level for events indicating that an internal program
+        function has been called with invalid arguments.  Code=6000.
+    *)
+    type invalid_t = [ `Invalid ]
+
+    (** The priority level for events indicating that an internal program
+        function is undefined for the given arguments.  Code=5000.
+    *)
+    type fail_t = [ `Fail ]
+
+    (** The priority level for events indicating that a program has encountered
+        invalid input.  The program may or may not be able to recover and
+        continue processing further input correctly.  Code=4000.
+    *)
+    type error_t = [ `Error ]
+
+    (** The priority level for events indicating that a program has encountered
+        unexpected input.  The program is expected to recover and continue
+        processing further input correctly.  Code=3000.
+    *)
+    type warn_t = [ `Warn ]
+
+    (** The priority level for events indicating significant information about
+        the processing of the program useful for diagnosing external processes.
+        Code=2000.
+    *)
+    type info_t = [ `Info ]
+
+    (** The priority level for events describing internal processing of the
+        program for the purpose of diagnosing programming errors.  Code=1000.
+    *)
+    type debug_t = [ `Debug ]
+    
+    (** The priority levels corresponding to events that the basic agent has
+        public methods for journaling.
+    *)
+    type basic_t = [ invalid_t | fail_t | error_t | warn_t | info_t | debug_t ]
+    
+    (** Additional priority levels corresponding to limit levels in the basic
+        event prioritizer used for completely enabling or disabling all
+        messages.  These levels do not have message tags defined.
+    *)
+    type enable_t = [ `None | `All ]
+    
+    (** The sum of all basic priority levels. *)
+    type level_t = [ basic_t | enable_t ]
+end
+
+(** The basic prioritizer class, defining the priority codes and message tags
+    for all of the basic priority levels: [`Invalid], [`Fail], [`Error],
+    [`Warn], [`Info] and [`Debug].  Derive a subclass to define a prioritizer
+    for additional priority levels corresponding to other integer codes.
+*)
+class ['level] basic_prioritizer :
+    object
+        constraint 'level = [> Basic.level_t ]
+
+        (** Returns the integer corresponding to the priority level. *)
+        method code: 'level -> Basic.Priority.t
+        
+        (** Returns the message tag corresponding to the priority level. *)
+        method tag: 'level -> string
+    end
+
+(** The basic channel archiver.  Use [new basic_channel_archiver c] to
+    construct an archiver that emits each basic event [e] with a priority level
+    less than [`Fail] to the channel [c] using [Printf.fprintf c "%s: %s\n"
+    e#prioritizer#tag e#message].
+*)
+class ['event] basic_channel_archiver:
+    out_channel ->
+    object
+        constraint 'event = [> Basic.level_t ] #Basic.event
+
+        (** Returns the channel used to construct the archiver. *)
+        method channel: out_channel
+        
+        (** Emits each basic event [e] with a priority level less than [`Fail]
+            to the channel [c] using [Printf.fprintf c "%s: %s\n"
+            e#prioritizer#tag e#message].
+        *)
+        method emit: 'event -> unit
+    end
+
+(** The basic journaling agent.  Derive a subclass to define an agent that can
+    construct events derived from the basic event (which may also require
+    archivers derived from the basic archiver that can format any additional
+    required output).  The class defines six public methods for output of
+    diagnostic events, one for each basic priority level.
+*)
+class virtual ['archiver] basic_agent:
+    'level #basic_prioritizer -> 'level -> 'archiver list ->
+    object
+        constraint 'level = [> Basic.level_t ]
+        constraint 'event = 'level #Basic.event
+        constraint 'archiver = 'event #Basic.archiver
+        inherit ['archiver] Basic.agent
+
+        (** Use [a#invalid msg ...] to format message text to put to the
+            archivers at the [`Invalid] level, and finally used to raise an
+            [Invalid_argument] exception.
+        *)
+        method invalid: 'a 'b. ('a, unit, string, 'b) format4 -> 'a
+
+        (** Use [a#fail msg ...] to format message text to put to the
+            archivers at the [`Fail] level, and finally used to raise an
+            [Failure] exception.
+        *)
+        method fail: 'a 'b. ('a, unit, string, 'b) format4 -> 'a
+
+        (** Use [a#error msg ...] to format message text to put to the
+            archivers at the [`Error] level.
+        *)
+        method error: 'a. ('a, unit, string, unit) format4 -> 'a
+
+        (** Use [a#warn msg ...] to format message text to put to the
+            archivers at the [`Warn] level.
+        *)
+        method warn: 'a. ('a, unit, string, unit) format4 -> 'a
+
+        (** Use [a#info msg ...] to format message text to put to the
+            archivers at the [`Info] level.
+        *)
+        method info: 'a. ('a, unit, string, unit) format4 -> 'a
+
+        (** Use [a#debug msg ...] to format message text to put to the
+            archivers at the [`Debug] level.  The result of the formatting
+            continuation is always [true].  This is to facilitate using the
+            method inside [assert] blocks.
+        *)
+        method debug: 'a. ('a, unit, string, bool) format4 -> 'a
+    end
+
+(** A basic agent, initially set with a limit of [`Warn], and with with one
+    basic archiver for the [Pervasives.stdout] channel.
+*)
+val stdout: Basic.level_t Basic.event Basic.archiver basic_agent
+
+(** A basic agent, initially set with a limit of [`Warn], and with with one
+    basic archiver for the [Pervasives.stderr] channel.
+*)
+val stderr: Basic.level_t Basic.event Basic.archiver basic_agent
+
+(*--- End of File [ cf_journal.mli ] ---*)
 
 module DFA: (Cf_dfa.T with module S = Symbol) = Cf_dfa.Create(Symbol)
 
+class cursor = [char] Cf_dfa.cursor
 type expr_t = DFA.expr_t
 type ('c, 'x) rule_t = ('c, 'x) DFA.rule_t
 type ('c, 'x) t = ('c, 'x) DFA.t
-type 'c raise_exn_t = 'c DFA.raise_exn_t
 
 module Op = struct
     include DFA.Op
 class line_cursor ?(c = counter_zero) newline =
     let nl0 = Cf_seq.to_list (Cf_seq.of_string newline) in
     object(self:'self)
-        inherit [Symbol.t] Cf_parser.cursor c.c_pos
+        inherit cursor c.c_pos
 
         val row_: int = c.c_row
         val col_: int = c.c_col
     expressions are not provided.
 *)
 
+(** {6 Classes} *)
+
+(** The class of cursors used by lazy DFA parser.  It inherits from the
+    basic parser and defines a new method for handling errors.
+*)
+
+class cursor:
+    int ->  (** The initial position, i.e. usually zero *)
+    object('self)
+        inherit [char] Cf_parser.cursor
+        
+        (** This method is invoked as [c#error n z] in a lexer when no rule
+            matches the input stream [z] after [n] characters.  The purpose is
+            to give a derived class an opportunity to raise an exception rather
+            than allow the parser to return without a match.  In this base
+            class, the method has no side effect.
+        *)
+        method error: int -> (char * 'self) Cf_seq.t -> unit
+    end
+
 (** {6 Types} *)
 
 (** The type of lexer expressions. *)
 type expr_t
 
 (** The type of lexer rules. *)
-type ('c, 'x) rule_t constraint 'c = char #Cf_parser.cursor
+type ('c, 'x) rule_t constraint 'c = #cursor
 
 (** The type of lexical analyzers, which are defined as parsers that use input
     symbols of type [char].
 *)
-type ('c, 'x) t = ('c, char, 'x) Cf_parser.X.t
-    constraint 'c = char #Cf_parser.cursor
-
-(** The type of exception handlers in lexical analyzers. *)
-type 'c raise_exn_t = int -> (char * 'c) Cf_seq.t -> exn
-    constraint 'c = char #Cf_parser.cursor
+type ('c, 'x) t = ('c, char, 'x) Cf_parser.X.t constraint 'c = #cursor
 
 (** {6 Functions} *)
 
-(* Open this module to bring the operator functions into the current scope. *)
+(** Open this module to bring the operator functions into the current scope. *)
 module Op: sig
 
     (** Use [!:c] to compose an expression that matches the character [c]. *)
 *)
 val nil: expr_t
 
-(** Use [create ?xf r] to compose a lexical analyzer from the rule [r] and the
-    optional exception handler [xf].
-*)
-val create: ?xf:'c raise_exn_t -> ('c, 'x) rule_t -> ('c, 'x) t
+(** Use [create ?xf r] to compose a lexical analyzer from the rule [r]. *)
+val create: ('c, 'x) rule_t -> ('c, 'x) t
 
 (** A record used by the [line_cursor] class defined below that indicates the
     character index, row and column in the input stream associated with a
     ?c:counter_t ->
     string ->
     object
-        inherit [char] Cf_parser.cursor
+        inherit cursor
         
         val row_: int           (** The current row number *)
         val col_: int           (** The current column number *)
     cursors of the [#line_cursor] class type.  When the exception handler is
     called, the exception returned is constructed as [Error c#counter].
 *)
-val raise_exn: #line_cursor raise_exn_t
+val raise_exn: int -> (char * #line_cursor) Cf_seq.t -> exn
 
 (*--- End of File [ cf_lexer.mli ] ---*)

cf/cf_nameinfo_p.c

 CAMLprim value cf_nameinfo_specialize_sockaddr(value sxVal, value domainVal)
 {
     CAMLparam2(sxVal, domainVal);
-    CAMLlocal1(resultVal);
+    CAMLlocal2(resultVal, someVal);
     
     const Cf_socket_sockaddrx_unit_t* sxPtr;
     const Cf_socket_domain_t* domainPtr;
     domainPtr = Cf_socket_domain_val(domainVal);
     resultVal = Val_int(0);
     
-    if ((int) domainPtr->d_family == (int) sxPtr->sx_sockaddr.sa_family) {
-        CAMLlocal1(someVal);
-        
+    if ((int) domainPtr->d_family == (int) sxPtr->sx_sockaddr.sa_family) {        
         someVal = domainPtr->d_consaddr((struct sockaddr*) &sxPtr->sx_sockaddr,
             domainPtr->d_socklen);
 
         resultVal = alloc_small(1, 0);
-        Field(resultVal, 0) = someVal;
+        Store_field(resultVal, 0, someVal);
     }
     
     CAMLreturn(resultVal);
             return Val_int(i);
     
     resultVal = alloc_small(1, 0);
-    Field(resultVal, 0) = Val_int(error);
+    Store_field(resultVal, 0, Val_int(error));
     return resultVal;
 }
 
     
     flagsVal = alloc_small(Cf_nameinfo_of_address_flags_array_size, 0);
     for (i = 0; i < Cf_nameinfo_of_address_flags_array_size; ++i)
-        Field(flagsVal, i) = (flags & cf_nameinfo_of_address_flags_array[i])
-            ? Val_true : Val_false;
+        Store_field(flagsVal, i,
+            (flags & cf_nameinfo_of_address_flags_array[i])
+            ? Val_true : Val_false);
     
     CAMLreturn(flagsVal);
 }
     unresolvedVal = cf_nameinfo_unresolved_of_code(error);
     
     resultVal = alloc_small(2, 0);
-    Field(resultVal, 0) = *cf_nameinfo_unresolved_exn;
-    Field(resultVal, 1) = unresolvedVal;
+    Store_field(resultVal, 0, *cf_nameinfo_unresolved_exn);
+    Store_field(resultVal, 1, unresolvedVal);
     mlraise(resultVal);
     
     CAMLreturn0;
     if (error) cf_nameinfo_raise_unresolved(error, syserror, "getnameinfo");
     
     resultVal = alloc_small(2, 0);
-    Field(resultVal, 0) = hostNameVal;
-    Field(resultVal, 1) = servNameVal;
+    Store_field(resultVal, 0, hostNameVal);
+    Store_field(resultVal, 1, servNameVal);
     
     CAMLreturn(resultVal);
 }
 CAMLprim value cf_nameinfo_to_address(value hintOptVal, value argVal)
 {
     CAMLparam2(hintOptVal, argVal);
-    CAMLlocal1(listVal);
+    CAMLlocal4(listVal, hintVal, flagsVal, prevVal);
+    CAMLlocal4(nextVal, infoVal, familyVal, socktypeVal);
+    CAMLlocal4(protocolVal, cnameVal, addrVal, strVal);            
     
     int error, syserror;
     const char* hostname;
         break;
     }
     
-    if (Is_block(hintOptVal)) {
-        CAMLlocal2(hintVal, flagsVal);
-        
+    if (Is_block(hintOptVal)) {        
         memset(&hints, 0, sizeof hints);
         hintVal = Field(hintOptVal, 0);
         flagsVal = Field(hintVal, 0);
     if (error) cf_nameinfo_raise_unresolved(error, syserror, "getaddrinfo");
 
     if (resultPtr) {
-        CAMLlocal1(prevVal);
         const struct addrinfo* p;
         
         prevVal = Val_int(0);
         
         for (p = resultPtr; !!p; p = p->ai_next) {
-            CAMLlocal4(nextVal, infoVal, familyVal, socktypeVal);
-            CAMLlocal4(protocolVal, cnameVal, addrVal, flagsVal);
-            
             Cf_socket_domain_t domain;
             
             flagsVal = cf_nameinfo_default_ai_flags_val;
             if (p->ai_flags) {
                 flagsVal = alloc_small(3, 0);
-                Field(flagsVal, 0) = Bool_val(p->ai_flags & AI_PASSIVE);
-                Field(flagsVal, 1) = Bool_val(p->ai_flags & AI_CANONNAME);
-                Field(flagsVal, 2) = Bool_val(p->ai_flags & AI_NUMERICHOST);
+                Store_field(flagsVal, 0, Bool_val(p->ai_flags & AI_PASSIVE));
+                Store_field(flagsVal, 1, Bool_val(p->ai_flags & AI_CANONNAME));
+                Store_field(flagsVal, 2,
+                    Bool_val(p->ai_flags & AI_NUMERICHOST));
             }
             
             domain = cf_nameinfo_pf_unspec;
             if (!p->ai_canonname) {
                 cnameVal = Val_int(0);
             }
-            else {
-                CAMLlocal1(strVal);
-                
+            else {                
                 strVal = copy_string(p->ai_canonname);
                 cnameVal = alloc_small(1, 0);
-                Field(cnameVal, 0) = strVal;
+                Store_field(cnameVal, 0, strVal);
             }
             
             addrVal = cf_nameinfo_sockaddr_cons(p->ai_addr, p->ai_addrlen);
             
             infoVal = alloc_small(6, 0);
-            Field(infoVal, 0) = flagsVal;
-            Field(infoVal, 1) = familyVal;
-            Field(infoVal, 2) = socktypeVal;
-            Field(infoVal, 3) = protocolVal;
-            Field(infoVal, 4) = cnameVal;
-            Field(infoVal, 5) = addrVal;
+            Store_field(infoVal, 0, flagsVal);
+            Store_field(infoVal, 1, familyVal);
+            Store_field(infoVal, 2, socktypeVal);
+            Store_field(infoVal, 3, protocolVal);
+            Store_field(infoVal, 4, cnameVal);
+            Store_field(infoVal, 5, addrVal);
             
             nextVal = alloc_small(2, 0);
-            Field(nextVal, 0) = infoVal;
-            Field(nextVal, 1) = Val_int(0);
+            Store_field(nextVal, 0, infoVal);
+            Store_field(nextVal, 1, Val_int(0));
             
             if (!Is_block(listVal))
                 listVal = nextVal;
 
     register_global_root(&cf_nameinfo_default_ai_flags_val);
     cf_nameinfo_default_ai_flags_val = alloc_small(3, 0);
-    Field(cf_nameinfo_default_ai_flags_val, 0) = Val_false;
-    Field(cf_nameinfo_default_ai_flags_val, 1) = Val_false;
-    Field(cf_nameinfo_default_ai_flags_val, 2) = Val_false;
+    Store_field(cf_nameinfo_default_ai_flags_val, 0, Val_false);
+    Store_field(cf_nameinfo_default_ai_flags_val, 1, Val_false);
+    Store_field(cf_nameinfo_default_ai_flags_val, 2, Val_false);
 
     return Val_unit;
 }
 CAMLprim value cf_netif_nameindex(value unit)
 {
     CAMLparam0();
-    CAMLlocal2(listVal, tailVal);
+    CAMLlocal5(listVal, tailVal, nameVal, pairVal, cellVal);
     struct if_nameindex* mapPtr;
     struct if_nameindex* cellPtr;
 
     listVal = Val_int(0);
     tailVal = Val_int(0);
 
-    for (cellPtr = mapPtr; cellPtr->if_name; cellPtr++) {
-        CAMLlocal3(nameVal, pairVal, cellVal);
-        
+    for (cellPtr = mapPtr; cellPtr->if_name; cellPtr++) {        
         nameVal = copy_string(cellPtr->if_name);
         
         pairVal = alloc_small(2, 0);
-        Field(pairVal, 0) = Val_int(cellPtr->if_index);
-        Field(pairVal, 1) = nameVal;
+        Store_field(pairVal, 0, Val_int(cellPtr->if_index));
+        Store_field(pairVal, 1, nameVal);
         
         cellVal = alloc_small(2, 0);
-        Field(cellVal, 0) = pairVal;
-        Field(cellVal, 1) = Val_int(0);
+        Store_field(cellVal, 0, pairVal);
+        Store_field(cellVal, 1, Val_int(0));
         
         if (!Is_block(listVal))
             listVal = cellVal;
                 Some (x, seq'')
 end
 
+let rec filter f p s =
+    match p s with
+    | None -> None
+    | Some (x, s) as v -> if f x then v else filter f p s
+
+let map f p s =
+    match p s with
+    | None -> None
+    | Some (x, s) -> Some (f x, s)
+
+let rec optmap f p s =
+    match p s with
+    | None -> None
+    | Some (x, s) ->
+        match f x with
+        | None -> optmap f p s
+        | Some y -> Some (y, s)
+
 (*--- End of File [ cf_parser.ml ] ---*)
 (** A parser that never recognizes any input, i.e. it always returns [None]. *)
 val nil: ('i, 'o) t
 
-(** Use [err f] to compose parser that applies [f] to the input token stream to
-    obtain an Objective Caml exception, then raises the exception.
+(** Use [err f] to compose parser that applies the input token stream to the
+    function [f] to obtain an Objective Caml exception, then raises the
+    exception.
 *)
 val err: ('i Cf_seq.t -> exn) -> ('i, 'x) t
 
     *)
     val weave: c:('i #cursor as 'c) -> 'i Cf_seq.t -> ('i * 'c) Cf_seq.t
 
-
     (** Use [sat f] to create a parser that recognizes, shifts and reduces
         input tokens for which the satisfier function [f] returns [true].
     *)
     val ( %= ): ('c, 'i, 'x) X.t -> ('c, 'x, 'o) X.t -> ('c, 'i, 'o) X.t
 end
 
+(** Use [filter f p] to produce a parser that applies [f] to each output symbol
+    of [p] and ignores all those for which the result is [false].
+*)
+val filter: ('o -> bool) -> ('i, 'o) t -> ('i, 'o) t
+
+(** Use [map f p] to produce a parser that transforms each output symbol of [p]
+    by applying [f] to its value.
+*)
+val map: ('x -> 'y) -> ('i, 'x) t -> ('i, 'y) t
+
+(** Use [optmap f p] to produce a parser that transforms each output symbol of
+    [p] by applying [f] to its value and ignoring all those for which the
+    result is [None].
+*)
+val optmap: ('x -> 'y option) -> ('i, 'x) t -> ('i, 'y) t
+
 (*--- End of File [ cf_parser.mli ] ---*)
         (*
         let buf = Buffer.create 32 in
         Buffer.add_char buf '[';
-        List.iter (fun n ->
+        List.iter begin fun n ->
             Buffer.add_string buf (Printf.sprintf " %d" n);
-        ) sigs;
+        end sigs;
         Buffer.add_string buf " ]";
         let sigstr = Buffer.contents buf in
         xprintf "selecting: dt=%f sigs=%s fdsetlen=(%d,%d,%d)\n"

cf/cf_scan_parser.ml

+(*---------------------------------------------------------------------------*
+  IMPLEMENTATION  cf_scan_parser.ml
+
+  Copyright (c) 2004, James H. Woodyatt
+  All rights reserved.
+
+  Redistribution and use in source and binary forms, with or without
+  modification, are permitted provided that the following conditions
+  are met:
+
+    Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+    Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution
+
+  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+  OF THE POSSIBILITY OF SUCH DAMAGE. 
+ *---------------------------------------------------------------------------*)
+
+exception No_match
+
+class virtual ['i] scanner z =
+    object(self)
+        val mutable this_: 'i Cf_seq.t = z
+        val mutable next_: 'i Cf_seq.t = z
+
+        method private virtual get: char
+        
+        method init = Scanf.Scanning.from_function (fun () -> self#get)
+        method fini = this_
+    end
+
+let cscanf cf ef fmt rf z =
+    let s = cf z in
+    let ef0 _ x = ef s x in
+    try
+        let v = Scanf.kscanf s#init ef0 fmt rf in
+        let z = s#fini in
+        Some (v, z)
+    with
+    | No_match ->
+        None
+
+class ['cursor] lex_scanner z =
+    object
+        constraint 'cursor = #Cf_lexer.cursor
+        inherit [char * 'cursor] scanner z
+                
+        method private get =
+            this_ <- next_;
+            match Lazy.force this_ with
+            | Cf_seq.Z ->
+                raise End_of_file
+            | Cf_seq.P ((ch, _), tl) ->
+                next_ <- tl;
+                ch
+    end
+
+let scanf fmt rf z =
+    let ef _ = raise No_match in
+    cscanf (new lex_scanner) ef fmt rf z
+
+(*--- End of File [ cf_scan_parser.ml ] ---*)

cf/cf_scan_parser.mli

+(*---------------------------------------------------------------------------*
+  INTERFACE  cf_scan_parser.mli
+
+  Copyright (c) 2004, James H. Woodyatt
+  All rights reserved.
+
+  Redistribution and use in source and binary forms, with or without
+  modification, are permitted provided that the following conditions
+  are met:
+
+    Redistributions of source code must retain the above copyright
+    notice, this list of conditions and the following disclaimer.
+
+    Redistributions in binary form must reproduce the above copyright
+    notice, this list of conditions and the following disclaimer in
+    the documentation and/or other materials provided with the
+    distribution
+
+  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+  ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+  LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
+  FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
+  COPYRIGHT HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
+  INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+  (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+  SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
+  STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+  ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED
+  OF THE POSSIBILITY OF SUCH DAMAGE. 
+ *---------------------------------------------------------------------------*)
+
+(** Lexical analysis with functional composition using [Scanf] scanners. *)
+
+(** {6 Overview}
+
+    This module implements and extension to the {!Cf_lexer} module for mixing
+    calls to the standard library [Scanf] functions with functional parsers.
+*)
+
+(** {6 Classes and Types} *)
+
+(** An exception provided so that the [cscanf] function (below) can be signaled
+    to transform its answer with the effect that the parser stack is unwound
+    until an alternative production can be matched.
+*)
+exception No_match
+
+(** A virtual base class used in the [cscanf] function (below) for constructing
+    a scanning buffer from an input sequence.
+*)
+class virtual ['i] scanner:
+    'i Cf_seq.t ->      (** The input sequence *)
+    object
+        val mutable this_: 'i Cf_seq.t  (** The current input symbol *)
+        val mutable next_: 'i Cf_seq.t  (** The next unmatched input symbol *)
+
+        (** Get the next character for the scanning buffer *)
+        method private virtual get: char
+        
+        (** Initialize the scanning buffer *)
+        method init: Scanf.Scanning.scanbuf
+        
+        (** Finalize the scanning buffer and return the next unmatched input
+            symbol.
+        *)
+        method fini: 'i Cf_seq.t
+    end
+
+(** {6 Functions} *)
+
+(** This is the primitive function in the module.  Use [cscanf cf ef fmt rf] to
+    construct a parser that applies [cf] to the input sequence to acquire a
+    scanner object [s], invokes the [s#init] method to obtain a scanning buffer
+    with which to apply [Scanf.kscanf], using the exception function [ef], the
+    scanning format [fmt] and the return continuation [rf].  If the exception
+    function raises [No_match] then the resulting parser unwinds to the next
+    production alternative, otherwise the parser answers with the result of the
+    return continuation.
+*)
+val cscanf:
+    ('i Cf_seq.t -> ('i #scanner as 's)) -> ('s -> exn -> 'o) ->
+    ('f, Scanf.Scanning.scanbuf, 'o) format -> 'f -> ('i, 'o) Cf_parser.t
+
+(** Use [scanf fmt rf] to construct a lexical parser that scans the input text
+    according to the scanning format [fmt] and produces the value returned by
+    the return continuation.  If the scanner raises an exception, then the
+    parser unwinds to the next production alternative.
+*)
+val scanf:
+    ('f, Scanf.Scanning.scanbuf, 'o) format -> 'f -> ('c, 'o) Cf_lexer.t
+
+(*--- End of File [ cf_scan_parser.mli ] ---*)
   are met:
 
     Redistributions of source code must retain the above copyright
-    notice, this list of conditions and the following disclaimer.
+    notice, this list of conditions and the following disclaimer.
 
     Redistributions in binary form must reproduce the above copyright
     notice, this list of conditions and the following disclaimer in
     fdVal[1] = cf_socket_alloc(fd[1], type, protocol, domainPtr);
 
     resultVal = alloc_small(2, 0);
-    Field(resultVal, 0) = fdVal[0];
-    Field(resultVal, 1) = fdVal[1];
+    Store_field(resultVal, 0, fdVal[0]);
+    Store_field(resultVal, 1, fdVal[1]);
     CAMLreturn(resultVal);
 }
 
     
     flagsVal = alloc_small(Cf_socket_msg_flags_array_size, 0);
     for (i = 0; i < Cf_socket_msg_flags_array_size; ++i)
-        Field(flagsVal, i) = (flags & cf_socket_msg_flags_array[i])
-            ? Val_true : Val_false;
+        Store_field(flagsVal, i,
+            (flags & cf_socket_msg_flags_array[i]) ? Val_true : Val_false);
     
     CAMLreturn(flagsVal);
 }
        (newFd, sockPtr->s_socktype, sockPtr->s_protocol, &sockPtr->s_domain);
     
     resultVal = alloc_small(2, 0);
-    Field(resultVal, 0) = newSockVal;
-    Field(resultVal, 1) = sxVal;
+    Store_field(resultVal, 0, newSockVal);
+    Store_field(resultVal, 1, sxVal);
     
     CAMLreturn(resultVal);
 }
     sxVal = sockPtr->s_domain.d_consaddr(saPtr, addrLen);
 
     resultVal = alloc_small(2, 0);
-    Field(resultVal, 0) = Val_int(result);
-    Field(resultVal, 1) = sxVal;
+    Store_field(resultVal, 0, Val_int(result));
+    Store_field(resultVal, 1, sxVal);
     
     CAMLreturn(resultVal);
 }
     
     if (optval.l_onoff) {
         result = alloc_small(1, 0);
-        Field(result, 0) = Val_int(optval.l_linger);
+        Store_field(result, 0, Val_int(optval.l_linger));
     }
     else
         result = Val_int(0);
            ("Cf_tai64: Range_error exception unavailable in primitive.");
     
     exnVal = alloc_small(1, 0);
-    Field(exnVal, 0) = *cf_tai64_range_error_exn;
+    Store_field(exnVal, 0, *cf_tai64_range_error_exn);
     mlraise(exnVal);
 
     CAMLreturn0;
            ("Cf_tai64: Label_error exception unavailable in primitive.");
     
     exnVal = alloc_small(1, 0);
-    Field(exnVal, 0) = *cf_tai64_label_error_exn;
+    Store_field(exnVal, 0, *cf_tai64_label_error_exn);
     mlraise(exnVal);
 
     CAMLreturn0;
     tai64Val = cf_tai64_alloc(&tai64);
     
     resultVal = alloc_small(2, 0);
-    Field(0, resultVal) = tai64Val;
-    Field(1, resultVal) = Val_int(Cf_tai64n_val(tai64nVal)->ns);
+    Store_field(resultVal, 0, tai64Val);
+    Store_field(resultVal, 1, Val_int(Cf_tai64n_val(tai64nVal)->ns));
     
     CAMLreturn(resultVal);
 }
             rel
     in
     let revpath = List.rev_append rel base in
-    try
-        let revpath = normalize_segment_revlist_ revpath in
-        match List.rev revpath with
-        | [] -> empty_segment_, []
-        | hd :: tl -> hd, tl
-    with
-    | Rel_undefined ->
-        invalid_arg "Cf_uri.refer_to_base: relative URI undefined in base."
+    let revpath = normalize_segment_revlist_ revpath in
+    match List.rev revpath with
+    | [] -> empty_segment_, []
+    | { seg_name = ".." } :: _ -> raise Rel_undefined
+    | hd :: tl -> hd, tl
 
 let refer_to_base_abs_path_ ~base:(`Abs abs) ~rel =
     match (rel.rel_path :> path_t) with
         let hier = { abs_hier_path = path; abs_hier_query = rel.rel_query } in
         { base with abs_special = S_hier hier }
 
-let cursor0_ = new Cf_parser.cursor 0
+let cursor0_ = new Cf_lexer.cursor 0
 
 let p_uri_ = Cf_parser.alt [
     (p_absolute_uri_ >>= fun x -> ~:(A x));