cf-0.10/0000755000175000017500000000000011021415424011710 5ustar smimramsmimramcf-0.10/.cvsignore0000644000175000017500000000007610116500413013710 0ustar smimramsmimram.DS_store *.cmo *.cmi *.cmx *.cma *.cmxa ocamltop t.* t-opt.* cf-0.10/.depend0000644000175000017500000001300110716231173013152 0ustar smimramsmimramcf_tai64_p.o: cf_tai64_p.c cf_tai64_p.h cf_common_p.h \ /usr/local/lib/ocaml/caml/alloc.h \ /usr/local/lib/ocaml/caml/compatibility.h \ /usr/local/lib/ocaml/caml/misc.h /usr/local/lib/ocaml/caml/config.h \ /usr/local/lib/ocaml/caml/mlvalues.h \ /usr/local/lib/ocaml/caml/callback.h /usr/local/lib/ocaml/caml/custom.h \ /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/intext.h \ /usr/local/lib/ocaml/caml/memory.h /usr/local/lib/ocaml/caml/misc.h \ /usr/local/lib/ocaml/caml/mlvalues.h cf_tai64n_p.o: cf_tai64n_p.c cf_tai64n_p.h cf_tai64_p.h cf_common_p.h \ /usr/local/lib/ocaml/caml/alloc.h \ /usr/local/lib/ocaml/caml/compatibility.h \ /usr/local/lib/ocaml/caml/misc.h /usr/local/lib/ocaml/caml/config.h \ /usr/local/lib/ocaml/caml/mlvalues.h \ /usr/local/lib/ocaml/caml/callback.h /usr/local/lib/ocaml/caml/custom.h \ /usr/local/lib/ocaml/caml/fail.h /usr/local/lib/ocaml/caml/intext.h \ /usr/local/lib/ocaml/caml/memory.h /usr/local/lib/ocaml/caml/misc.h \ /usr/local/lib/ocaml/caml/mlvalues.h cf_scmonad.cmi: cf_cmonad.cmi cf_tai64n.cmi: cf_tai64.cmi cf_stdtime.cmi: cf_tai64.cmi cf_journal.cmi: cf_ordered.cmi cf_seq.cmi: cf_smonad.cmi cf_scmonad.cmi cf_cmonad.cmi cf_deque.cmi: cf_seq.cmi cf_flow.cmi: cf_seq.cmi cf_scmonad.cmi cf_either.cmi cf_cmonad.cmi cf_heap.cmi: cf_seq.cmi cf_pqueue.cmi: cf_seq.cmi cf_map.cmi: cf_seq.cmi cf_set.cmi: cf_seq.cmi cf_sbheap.cmi: cf_pqueue.cmi cf_ordered.cmi cf_heap.cmi cf_rbtree.cmi: cf_set.cmi cf_ordered.cmi cf_map.cmi cf_gadget.cmi: cf_flow.cmi cf_cmonad.cmi cf_state_gadget.cmi: cf_flow.cmi cf_cmonad.cmi cf_machine.cmi: cf_state_gadget.cmi cf_unicode.cmi: cf_seq.cmi cf_flow.cmi cf_parser.cmi: cf_seq.cmi cf_message.cmi: cf_seq.cmi cf_deque.cmi cf_dfa.cmi: cf_seq.cmi cf_parser.cmi cf_regex.cmi: cf_seq.cmi cf_parser.cmi cf_flow.cmi cf_dfa.cmi cf_lex.cmi: cf_seq.cmi cf_regex.cmi cf_parser.cmi cf_scan_parser.cmi: cf_seq.cmi cf_parser.cmi cf_ordered.cmo: cf_ordered.cmi cf_ordered.cmx: cf_ordered.cmi cf_either.cmo: cf_either.cmi cf_either.cmx: cf_either.cmi cf_exnopt.cmo: cf_exnopt.cmi cf_exnopt.cmx: cf_exnopt.cmi cf_smonad.cmo: cf_smonad.cmi cf_smonad.cmx: cf_smonad.cmi cf_cmonad.cmo: cf_cmonad.cmi cf_cmonad.cmx: cf_cmonad.cmi cf_scmonad.cmo: cf_cmonad.cmi cf_scmonad.cmi cf_scmonad.cmx: cf_cmonad.cmx cf_scmonad.cmi cf_tai64.cmo: cf_tai64.cmi cf_tai64.cmx: cf_tai64.cmi cf_tai64n.cmo: cf_tai64.cmi cf_tai64n.cmi cf_tai64n.cmx: cf_tai64.cmx cf_tai64n.cmi cf_gregorian.cmo: cf_gregorian.cmi cf_gregorian.cmx: cf_gregorian.cmi cf_stdtime.cmo: cf_tai64.cmi cf_gregorian.cmi cf_stdtime.cmi cf_stdtime.cmx: cf_tai64.cmx cf_gregorian.cmx cf_stdtime.cmi cf_journal.cmo: cf_ordered.cmi cf_journal.cmi cf_journal.cmx: cf_ordered.cmx cf_journal.cmi cf_seq.cmo: cf_smonad.cmi cf_scmonad.cmi cf_cmonad.cmi cf_seq.cmi cf_seq.cmx: cf_smonad.cmx cf_scmonad.cmx cf_cmonad.cmx cf_seq.cmi cf_deque.cmo: cf_seq.cmi cf_deque.cmi cf_deque.cmx: cf_seq.cmx cf_deque.cmi cf_flow.cmo: cf_seq.cmi cf_either.cmi cf_deque.cmi cf_flow.cmi cf_flow.cmx: cf_seq.cmx cf_either.cmx cf_deque.cmx cf_flow.cmi cf_heap.cmo: cf_seq.cmi cf_heap.cmi cf_heap.cmx: cf_seq.cmx cf_heap.cmi cf_pqueue.cmo: cf_seq.cmi cf_pqueue.cmi cf_pqueue.cmx: cf_seq.cmx cf_pqueue.cmi cf_map.cmo: cf_seq.cmi cf_map.cmi cf_map.cmx: cf_seq.cmx cf_map.cmi cf_set.cmo: cf_seq.cmi cf_set.cmi cf_set.cmx: cf_seq.cmx cf_set.cmi cf_sbheap.cmo: cf_seq.cmi cf_ordered.cmi cf_sbheap.cmi cf_sbheap.cmx: cf_seq.cmx cf_ordered.cmx cf_sbheap.cmi cf_rbtree.cmo: cf_set.cmi cf_seq.cmi cf_ordered.cmi cf_rbtree.cmi cf_rbtree.cmx: cf_set.cmx cf_seq.cmx cf_ordered.cmx cf_rbtree.cmi cf_gadget.cmo: cf_seq.cmi cf_scmonad.cmi cf_rbtree.cmi cf_ordered.cmi \ cf_flow.cmi cf_deque.cmi cf_cmonad.cmi cf_gadget.cmi cf_gadget.cmx: cf_seq.cmx cf_scmonad.cmx cf_rbtree.cmx cf_ordered.cmx \ cf_flow.cmx cf_deque.cmx cf_cmonad.cmx cf_gadget.cmi cf_state_gadget.cmo: cf_seq.cmi cf_flow.cmi cf_cmonad.cmi cf_state_gadget.cmi cf_state_gadget.cmx: cf_seq.cmx cf_flow.cmx cf_cmonad.cmx cf_state_gadget.cmi cf_machine.cmo: cf_state_gadget.cmi cf_cmonad.cmi cf_machine.cmi cf_machine.cmx: cf_state_gadget.cmx cf_cmonad.cmx cf_machine.cmi cf_unicode.cmo: cf_seq.cmi cf_flow.cmi cf_unicode.cmi cf_unicode.cmx: cf_seq.cmx cf_flow.cmx cf_unicode.cmi cf_parser.cmo: cf_seq.cmi cf_parser.cmi cf_parser.cmx: cf_seq.cmx cf_parser.cmi cf_message.cmo: cf_seq.cmi cf_deque.cmi cf_message.cmi cf_message.cmx: cf_seq.cmx cf_deque.cmx cf_message.cmi cf_dfa.cmo: cf_seq.cmi cf_rbtree.cmi cf_parser.cmi cf_ordered.cmi cf_dfa.cmi cf_dfa.cmx: cf_seq.cmx cf_rbtree.cmx cf_parser.cmx cf_ordered.cmx cf_dfa.cmi cf_regex.cmo: cf_seq.cmi cf_parser.cmi cf_flow.cmi cf_dfa.cmi cf_regex.cmi cf_regex.cmx: cf_seq.cmx cf_parser.cmx cf_flow.cmx cf_dfa.cmx cf_regex.cmi cf_lex.cmo: cf_seq.cmi cf_regex.cmi cf_parser.cmi cf_lex.cmi cf_lex.cmx: cf_seq.cmx cf_regex.cmx cf_parser.cmx cf_lex.cmi cf_scan_parser.cmo: cf_seq.cmi cf_parser.cmi cf_scan_parser.cmi cf_scan_parser.cmx: cf_seq.cmx cf_parser.cmx cf_scan_parser.cmi t/t_cf.cmo: cf_tai64.cmi cf_stdtime.cmi cf_state_gadget.cmi cf_seq.cmi \ cf_scmonad.cmi cf_scan_parser.cmi cf_regex.cmi cf_rbtree.cmi \ cf_parser.cmi cf_ordered.cmi cf_lex.cmi cf_journal.cmi cf_gregorian.cmi \ cf_gadget.cmi cf_flow.cmi cf_deque.cmi cf_cmonad.cmi t/t_cf.cmx: cf_tai64.cmx cf_stdtime.cmx cf_state_gadget.cmx cf_seq.cmx \ cf_scmonad.cmx cf_scan_parser.cmx cf_regex.cmx cf_rbtree.cmx \ cf_parser.cmx cf_ordered.cmx cf_lex.cmx cf_journal.cmx cf_gregorian.cmx \ cf_gadget.cmx cf_flow.cmx cf_deque.cmx cf_cmonad.cmx cf-0.10/cf_cmonad.ml0000644000175000017500000000340710433520572014166 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_cmonad.ml Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) type ('x, 'a) t = ('a -> 'x) -> 'x module Op = struct let ( >>= ) m f g = m (fun a -> f a g) end let nil f = f () let return x f = f x let init y _ = y let cont f g = f (g ()) let eval m x = m (fun () -> x) (*--- End of File [ cf_cmonad.ml ] ---*) cf-0.10/cf_cmonad.mli0000644000175000017500000000663410433520572014344 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_cmonad.mli Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) (** The continuation monad and its operators. *) (** {6 Overview} *) (** The continuation monad is provided here mostly for reference purposes, since it is helpful to refer to it when lifting into a more complex monad. A continuation monad represents a computation composed of stages that can be interrupted, resumed and rescheduled. Because Objective Caml is an eager language programming in the continuation-passing style (CPS) can be simplified by the use of the continuation monad and its operators. Note: see the {!Cf_gadget} module for an example of its use. *) (** {6 Types} *) (** The continuation monad: a function for passing intermediate results from continuation context to continuation context. *) type ('x, 'a) t = ('a -> 'x) -> 'x (** {6 Modules} *) (** A module containing the [( >>= )] binding operator for composition of continuation monads. *) module Op: sig (** Use [m >>= f] to produce a monad that applies [f] to the result of evaluating [m]. *) val ( >>= ): ('x, 'a) t -> ('a -> ('x, 'b) t) -> ('x, 'b) t end (** {6 Operators} *) (** A monad that returns [unit] and performs no operation. *) val nil: ('x, unit) t (** Use [return a] to produce a monad that returns [a] as an intermediate result from the current continuation. *) val return: 'a -> ('x, 'a) t (** Use [init x] to produce a monad that discards the current intermediate result and returns [x] as the continuation context. *) val init: 'x -> ('x, 'a) t (** Use [cont f] to produce a monad that passes the calling continuation to the function [f] and returns the unit value as an intermediate result. *) val cont: ('x -> 'x) -> ('x, unit) t (** Use [eval m] to evaluate the continuation monad to produce a function from initial continuation context to final continuation context. *) val eval: ('x, unit) t -> 'x -> 'x (*--- End of File [ cf_cmonad.mli ] ---*) cf-0.10/cf_common_p.c0000644000175000017500000000363110404616701014343 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_common_p.c Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_common_p.h" value cf_get_constant(const Cf_constant_table_t* tablePtr, int n) { const int* arrayPtr = tablePtr->array; unsigned int size = arrayPtr ? tablePtr->size : 0; unsigned int i; for (i = 0; i < size; ++i) { if (arrayPtr[i] == n) return (Val_int(i)); } return tablePtr->unknown(n); } /*--- End of File [ cf_common_p.c ] ---*/ cf-0.10/cf_common_p.h0000644000175000017500000000470210404616701014350 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_common_p.h Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_COMMON_P_H #define _CF_COMMON_P_H #include #include #include #include #include #include #include #include CAMLextern void enter_blocking_section(void); CAMLextern void leave_blocking_section(void); typedef value (*Cf_const_constructor_f)(int n); struct cf_constant_table_s { const int* array; unsigned int size; Cf_const_constructor_f unknown; }; typedef struct cf_constant_table_s Cf_constant_table_t; extern value cf_get_constant(const Cf_constant_table_t* tablePtr, int n); #define Nothing ((value) 0) /*--- These are imported from the unix library in the ocaml distro ---*/ extern void unix_error(int code, const char fname[], value arg) Noreturn; extern void uerror(const char* fname, value arg) Noreturn; #endif /* defined(_CF_COMMON_P_H) */ /*--- End of File [ cf_common_p.h ] ---*/ cf-0.10/cf_deque.ml0000644000175000017500000005260510433520572014034 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_deque.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (* A brief note about the algorithm in this module. This algorithm is an original invention, but it owes a few of its key insights to various algorithms published by Kaplan, Okasaki and Tarjan. While the algorithm here is not strictly a *pure* functional deque-- since it uses lazy evaluation in one place to amortize the cost of concatenation across calls to the pop function-- the inventor makes the baseless claim that it is substantially more efficient and simpler than other algorithms with similar complexity. The claim is baseless because benchmarks and evaluation criteria have not been made to compare this algorithm formally with published algorithms. However, informal testing by the inventor strongly suggests that the claim merits further investigation. The inventor invites other scientists to collaborate in the development of a scholarly paper about this algorithm and its performance characteristics. --j h woodyatt *) type 'a t = | Z (* An empty deque *) | Y of 'a (* A deque containing one element. *) | X of 'a * 'a (* An internal node of a deque that contains two elements. Nodes of this variant constructor are only allowed to be the left or right subnode of a U node (see below) that is itself a middle subnode of a U node that does not have an X subnode in the corresponding position. *) | U of 'a t * ('a * 'a) t * 'a t (* A deque, or an internal node of a deque that contains three subnodes: 1) a left node of single elements; 2) a middle node of element pairs; and 3) a right node of single elements. The middle subnode is never a Z, X or V node. The other subnodes are never U or V nodes. *) | V of 'a t * 'a t t Lazy.t * 'a t (* A deque composed by catenation. It contains three subnodes: 1) a left deque; 2) a lazy evaluation of a deque of deques, i.e. the suspension of the remaining results of catenation; and 3) a right deque. The left and right subnodes are never empty deques, and they are never V nodes themselves. *) (* An invariant rule is applied to the tree structure in order to obtain the recursive slowdown effect necessary to achieve O(1) asymptotic complexity in all the operations. The rule amounts to a requirement on the left and right subnodes in a stack of U nodes that may be mapped as digits in a redundant binary representation, i.e. Z, Y, and X nodes correspond to 0, 1 and 2 digits respectively. In redundant binary representation, a number is represented with the 0, 1 and 2 digits, with the rule demanding that when scanning the digits from most significant to least significant we always find at least one 0 digit after every 2 digit. The key insight to apply this invariant to the tree structure of a persistent functional deque comes from Kaplan and Tarjan [insert citation here]. *) let nil = Z let empty = function Z -> true | _ -> false module type Direction_T = sig val push: 'a -> 'a t -> 'a t val pop: 'a t -> ('a * 'a t) option val head: 'a t -> 'a val tail: 'a t -> 'a t val fold: ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b val of_list: 'a list -> 'a t val of_seq: 'a Cf_seq.t -> 'a t val to_list: 'a t -> 'a list val to_seq: 'a t -> 'a Cf_seq.t val to_seq2: 'a t -> ('a * 'a t) Cf_seq.t end module rec A: Direction_T = struct let rec push x = function | V (a, b, c) -> V (push x a, b, c) | U (Z, a, b) -> (* _0,_ -=> _1,_ *) U (Y x, a, b) | U (Y a, b, y0) -> begin match b with | Y (b,c) -> begin match y0 with | Z -> U (Y x, Y (a,b), Y c) | Y d -> U (Y x, U (Z, Y ((a,b),(c,d)), Z), Z) | _ -> assert (not true); Z end | U (Y (b,c), Y ((d,e),(f,g)), Y (h,i)) when y0 = Z -> U (Y x, U (Y (a,b), Y ((c,d),(e,f)), Y (g,h)), Y i) | U (b, c, d) -> let y1 = match b with | X (b1,b2) -> U (Y (x,a), A.push (b1,b2) c, d) | Y b -> begin match c, d with | Y (c,d), Z -> U (Y (x,a), Y (b,c), Y d) | _, _ -> U (X ((x,a),b), c, d) end | Z -> U (Y (x,a), c, d) | _ -> assert (not true); Z in U (Z, y1, y0) | _ -> assert (not true); Z end | Y a -> U (Z, Y (x,a), Z) | y -> assert (y = Z); Y x and pop = function | V (a, b, c) -> begin match pop a with | None -> assert (not true); None | Some (x, Z) -> let y = match A.pop (Lazy.force b) with | Some (y, b) -> V (y, Lazy.lazy_from_val b, c) | None -> c in Some (x, y) | Some (x, a) -> Some (x, V (a, b, c)) end | U (Y x, a, b) -> let y = match a, b with | Y (a,b), X (c,d) -> U (Y a, Y (b,c), Y d) | _, _ -> U (Z, a, b) in Some (x, y) | U (Z, a, b) -> begin match a, b with | Y (x,a), b -> let y = match b with | X (b,c) -> U (Y a, Y (b,c), Z) | Y b -> U (Z, Y (a,b), Z) | Z -> Y a | _ -> assert (not true); Z in Some (x, y) | U (a, y2, y1), y0 -> begin match a with | X ((x,a),b) -> Some (x, U (Y a, U (Y b, y2, y1), y0)) | Y (x,a) -> let y = match y2, y1 with | Y (b,c), X (d,e) -> U (Y b, Y (c,d), Y e) | Y _, _ -> U (Z, y2, y1) | U _, _ -> let (hd1,hd2), tl = match A.pop y2 with | Some (hd, tl) -> hd, tl | None -> assert false in U (X (hd1,hd2), tl, y1) | _, _ -> assert (not true); Z in Some (x, U (Y a, y, y0)) | Z -> let x, a, b = match y2 with | Y ((x,a),b) -> x, a, b | _ -> assert false in let y = match y1, y0 with | X (c,d), Y _ -> U (Z, Y (b,c), Y d) | Y c, _ -> U (Z, Y (b,c), Z) | Z, _ -> Y b | _, _ -> assert (not true); Z in Some (x, U (Y a, y, y0)) | _ -> assert (not true); None end | _, _ -> assert (not true); None end | Y x -> Some (x, Z) | y -> assert (y = Z); None let rec head = function | Y x | U (Y x, _, _) | U (Z, Y (x, _), _) | U (Z, U (Y (x, _), _, _), _) | U (Z, U (X ((x, _), _), _, _), _) | U (Z, U (Z, Y ((x, _), _), _), _) -> x | V (a, _, _) -> head a | y -> assert (y = Z); raise Not_found let tail d = match pop d with Some (_, d) -> d | None -> Z let rec fold f v = function | Z -> v | Y a -> f v a | X (a,b) -> f (f v a) b | U (a,b,c) -> let v = fold f v a in let g v (x, y) = f (f v x) y in let v = A.fold g v b in fold f v c | V (a,b,c) -> let v = fold f v a in let v = A.fold (fold f) v (Lazy.force b) in fold f v c let of_list s = List.fold_left (fun q a -> B.push a q) nil s let of_seq z = Cf_seq.fold (fun q a -> B.push a q) nil z let to_list d = B.fold (fun s a -> a :: s) [] d let rec to_seq d = lazy begin match pop d with | Some (hd, tl) -> Cf_seq.P (hd, to_seq tl) | None -> Cf_seq.Z end let rec to_seq2 d = lazy begin match pop d with | Some (hd, tl) -> Cf_seq.P ((hd, tl), to_seq2 tl) | None -> Cf_seq.Z end end and B: Direction_T = struct let rec push x = function | V (a, b, c) -> V (a, b, push x c) | U (a, b, Z) -> U (a, b, Y x) | U (y0, b, Y a) -> begin match b with | Y (c,b) -> begin match y0 with | Z -> U (Y c, Y (b,a), Y x) | Y d -> U (Z, U (Z, Y ((d,c),(b,a)), Z), Y x) | _ -> assert (not true); Z end | U (Y (i,h), Y ((g,f),(e,d)), Y (c,b)) when y0 = Z -> U (Y i, U (Y (h,g), Y ((f,e),(d,c)), Y (b,a)), Y x) | U (d, c, b) -> let y1 = match b with | X (b1,b2) -> U (d, B.push (b1,b2) c, Y (a,x)) | Y b -> begin match d, c with | Z, Y (d,c) -> U (Y d, Y (c,b), Y (a,x)) | _, _ -> U (d, c, X (b,(a,x))) end | Z -> U (d, c, Y (a,x)) | _ -> assert (not true); Z in U (y0, y1, Z) | _ -> assert (not true); Z end | Y a -> U (Z, Y (a,x), Z) | Z -> Y x | _ -> assert (not true); Z and pop = function | V (c, b, a) -> begin match pop a with | None -> assert (not true); None | Some (x, Z) -> let y = match B.pop (Lazy.force b) with | Some (y, b) -> V (c, Lazy.lazy_from_val b, y) | None -> c in Some (x, y) | Some (x, a) -> Some (x, V (c, b, a)) end | U (b, a, Y x) -> let y = match b, a with | X (d,c), Y (b,a) -> U (Y d, Y (c,b), Y a) | _, _ -> U (b, a, Z) in Some (x, y) | U (b, a, Z) -> begin match b, a with | b, Y (a,x) -> let y = match b with | X (c,b) -> U (Z, Y (c,b), Y a) | Y b -> U (Z, Y (b,a), Z) | Z -> Y a | _ -> assert (not true); Z in Some (x, y) | y0, U (y1, y2, a) -> begin match a with | X (b,(a,x)) -> Some (x, U (y0, U (y1, y2, Y b), Y a)) | Y (a,x) -> let y = match y1, y2 with | X (e,d), Y (c,b) -> U (Y e, Y (d,c), Y b) | _, Y _ -> U (y1, y2, Z) | _, U _ -> let (hd1,hd2), tl = match B.pop y2 with | Some (hd, tl) -> hd, tl | None -> assert false in U (y1, tl, X (hd1,hd2)) | _, _ -> assert (not true); Z in Some (x, U (y0, y, Y a)) | Z -> let b, a, x = match y2 with | Y (b,(a,x)) -> b, a, x | _ -> assert false in let y = match y0, y1 with | Y _, X (d,c) -> U (Y d, Y (c,b), Z) | _, Y c -> U (Z, Y (c,b), Z) | _, Z -> Y b | _, _ -> assert (not true); Z in Some (x, U (y0, y, Y a)) | _ -> assert (not true); None end | _, _ -> assert (not true); None end | X (a,x) -> Some (x, Y a) | Y x -> Some (x, Z) | y -> assert (y = Z); None let rec head = function | Y x | U (_, _, Y x) | U (_, Y (_, x), Z) | U (_, U (_, _, Y (_, x)), Z) | U (_, U (_, _, X (_, (_, x))), Z) | U (_, U (_, Y (_, (_, x)), Z), Z) -> x | V (_, _, a) -> head a | y -> assert (y = Z); raise Not_found let tail d = match pop d with Some (_, d) -> d | None -> Z let rec fold f v = function | Z -> v | Y a -> f v a | X (a,b) -> f (f v b) a | U (a,b,c) -> let v = fold f v c in let g v (x, y) = f (f v y) x in let v = B.fold g v b in fold f v a | V (a,b,c) -> let v = fold f v c in let v = B.fold (fold f) v (Lazy.force b) in fold f v a let of_list s = List.fold_left (fun q a -> A.push a q) nil s let of_seq z = Cf_seq.fold (fun q a -> A.push a q) nil z let to_list d = A.fold (fun s a -> a :: s) [] d let rec to_seq d = lazy begin match pop d with | Some (hd, tl) -> Cf_seq.P (hd, to_seq tl) | None -> Cf_seq.Z end let rec to_seq2 d = lazy begin match pop d with | Some (hd, tl) -> Cf_seq.P ((hd, tl), to_seq2 tl) | None -> Cf_seq.Z end end module type Iterators_T = sig val iterate: ('a -> unit) -> 'a t -> unit val predicate: ('a -> bool) -> 'a t -> bool val filter: ('a -> bool) -> 'a t -> 'a t val map: ('a -> 'b) -> 'a t -> 'b t val optmap: ('a -> 'b option) -> 'a t -> 'b t val listmap: ('a -> 'b list) -> 'a t -> 'b t val seqmap: ('a -> 'b Cf_seq.t) -> 'a t -> 'b t val partition: ('a -> bool) -> 'a t -> 'a t * 'a t val length: 'a t -> int val catenate: 'a t -> 'a t -> 'a t end module rec I: Iterators_T = struct let rec iterate f = function | Z -> () | Y a -> f a | X (a,b) -> f a; f b | U (a,b,c) -> iterate f a; I.iterate (fun (x,y) -> f x; f y) b; iterate f c | V (a,b,c) -> iterate f a; I.iterate (iterate f) (Lazy.force b); iterate f c let rec predicate f = function | Z -> true | Y a -> f a | X (a,b) -> f a && f b | U (a,b,c) -> predicate f a && I.predicate (fun (x,y) -> f x && f y) b && predicate f c | V (a,b,c) -> predicate f a && I.predicate (predicate f) (Lazy.force b) && predicate f c let filter f = let g d' x = if f x then B.push x d' else d' in A.fold g Z let rec map f = function | Z -> Z | Y a -> Y (f a) | X (a,b) -> X (f a, f b) | U (a,b,c) -> let a = map f a in let b = I.map (fun (x,y) -> f x, f y) b in let c = map f c in U (a, b, c) | V (a,b,c) -> let a = map f a in let b = Lazy.lazy_from_val (I.map (map f) (Lazy.force b)) in let c = map f c in V (a, b, c) let optmap f = let g d' x = match f x with Some y -> B.push y d' | None -> d' in fun d -> Cf_seq.fold g Z (A.to_seq d) let listmap f = let g d' x = List.fold_left (fun d x -> B.push x d) d' (f x) in fun d -> Cf_seq.fold g Z (A.to_seq d) let seqmap f = let g d' x = Cf_seq.fold (fun d x -> B.push x d) d' (f x) in fun d -> Cf_seq.fold g Z (A.to_seq d) let partition f = let g (d0, d1) x = if f x then B.push x d0, d1 else d0, B.push x d1 in fun d -> Cf_seq.fold g (Z, Z) (A.to_seq d) (** @param d A deque *) let rec length = function | Z -> 0 | Y _ -> 1 | X _ -> 2 | U (a,b,c) -> length a + length c + (2 * I.length b) | V (a,b,c) -> length a + length c + A.fold (fun n d -> n + length d) 0 (Lazy.force b) let rec catenate q1 q2 = match q1, q2 with | (Z, q | q, Z) -> q | Y a, x -> A.push a x | x, Y b -> B.push b x | (U _ as a), (U _ as b) -> V (a, Lazy.lazy_from_val Z, b) | (U _ as a), V (b, c, d) -> V (a, Lazy.lazy_from_val (A.push b (Lazy.force c)), d) | V (a, b, c), (U _ as d) -> V (a, Lazy.lazy_from_val (B.push c (Lazy.force b)), d) | V (a, b, c), V (d, e, f) -> let q1 = B.push c (Lazy.force b) and q2 = A.push d (Lazy.force e) in V (a, lazy (I.catenate q1 q2), f) | _, _ -> assert (not true); Z end include I (* let rec sprint f = function | Z -> Printf.sprintf "%c" '-' | Y a -> Printf.sprintf "%s" (f a) | X (a, b) -> Printf.sprintf "%s,%s" (f a) (f b) | U (a, b, c) -> let a = sprint f a in let b = (Obj.magic sprint) (fun (x1,x2) -> let x = sprint f (X (x1,x2)) in Printf.sprintf "(%s)" x ) b in let c = sprint f c in Printf.sprintf "[%s|%s|%s]" a b c | V (a, b, c) -> let a = sprint f a in let b = let g x = Printf.sprintf "<%s>" (sprint f x) in (Obj.magic sprint) g (Lazy.force b) in let c = sprint f c in Printf.sprintf "{%s;%s;%s}" a b c *) (*--- End of File [ cf_deque.ml ] ---*) cf-0.10/cf_deque.mli0000644000175000017500000001521510433520572014201 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_deque.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** A functional persistent double-ended catenable deque, with O{_ avg}(1) cost for every operation. Internally, this is a recursive data structure with height O(log N). *) (** The abstract type of a deque. *) type +'a t (** The empty deque. *) val nil: 'a t (** Returns [true] if the deque is the empty deque. *) val empty: 'a t -> bool (** Functions for operations on one of the two ends of a deque. *) module type Direction_T = sig (** [push x d] adds the element [x] to the end of the deque [d]. The average cost is constant. Worst-case running time is O(log N), which happens once in every N operations. Not tail-recursive. *) val push: 'a -> 'a t -> 'a t (** [pop d] returns [None] if [d] is the empty deque, otherwise it returns [Some (x, d')] where [x] is the element on the end of the deque, and [d'] is the remainder of [d] with the element [x] removed. The average cost is constant. Worst-case running time is O(log N), which happens once in every N operations. Not tail-recursive. *) val pop: 'a t -> ('a * 'a t) option (** [head d] returns the element at the end of the deque [d]. Raises [Not_found] if the deque is empty. Not tail-recursive. *) val head: 'a t -> 'a (** [tail d] is discards the element at the end of the deque [d]. Raises [Not_found] if the deque is empty. Not tail-recursive. *) val tail: 'a t -> 'a t (** [fold f a0 d] is [f (... (f (f a0 e0) e1) ...) en] when [e0..en] are the elements of the deque [d]. Not tail recursive. *) val fold: ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** Use [of_list s] to construct a deque from a list of elements. Th resulting elements begin at the head of the deque. *) val of_list: 'a list -> 'a t (** Use [of_seq z] to construct a deque from a sequence of elements. Evaluates the whole sequence and the resulting elements begin at the head of the deque.. *) val of_seq: 'a Cf_seq.t -> 'a t (** [to_list d] returns the elements in the deque in the order they would appear by successive calls of [pop d]. *) val to_list: 'a t -> 'a list (** [to_seq d] returns a lazily evaluated sequence of the elements in the deque in the order they would appear by successive calls of [pop d]. *) val to_seq: 'a t -> 'a Cf_seq.t (** [to_seq2 d] returns a lazily evaluated sequence of the pairs [(hd, tl)] obtained by successively calling of [pop d]. *) val to_seq2: 'a t -> ('a * 'a t) Cf_seq.t end module A: Direction_T (** Operations on the left end of a deque. *) module B: Direction_T (** Operations on the right end of a deque. *) (** [iterate f d] applies [f] to every element in [d] in left-to-right order. Not tail recursive. *) val iterate: ('a -> unit) -> 'a t -> unit (** [predicate f d] returns [true] if the result of applying [f] to every element in the deque [d] is [true], or if [d] is the empty deque. The order in which elements are applied is left to right. If [f] returns [false], then no more elements from [d] will be applied and the result will be returned immediately. Not tail recursive. *) val predicate: ('a -> bool) -> 'a t -> bool (** [filter f d] returns a new deque composed by applying [f] to every element in [d], including only those elements for which the result is [true]. The function is applied to the elements in the deque in left-to-right order. Not tail recursive. *) val filter: ('a -> bool) -> 'a t -> 'a t (** [map f d] returns a new deque composed by applying [f] to every element in [d] in left-to-right order. Not tail recursive. *) val map: ('a -> 'b) -> 'a t -> 'b t (** [optmap f d] returns a new deque composed by applying [f] to every element in [d] in left-to-right order, including only those elements of [d] for which [f] returns [Some] value. Not tail recursive. *) val optmap: ('a -> 'b option) -> 'a t -> 'b t (** [listmap f d] returns a new deque composed by applying [f] to every element in [d] in left-to-right order, taking all the resulting lists of elements in order. Not tail recursive. *) val listmap: ('a -> 'b list) -> 'a t -> 'b t (** [seqmap f d] returns a new deque composed by applying [f] to every element in [d] in left-to-right order, taking all the resulting sequences of elements in order. Not tail recursive. *) val seqmap: ('a -> 'b Cf_seq.t) -> 'a t -> 'b t (** [partition f s] returns two deques. The first is the deque of elements in [d] for which applying [f] results in [true], and the second is the deque of elements for which applying [f] results in [false]. The elements are applied in left-to-right order. *) val partition: ('a -> bool) -> 'a t -> 'a t * 'a t (** [length d] computes the number elements contained in the deque [d]. Not tail recursive. *) val length: 'a t -> int (** [catenate d1 d2] returns a new deque composed by joining the right end of [d1] to the left end of [d2]. The average cost is constant. Not tail-recursive. *) val catenate: 'a t -> 'a t -> 'a t (*--- End of File [ cf_deque.mli ] ---*) cf-0.10/cf_dfa.ml0000644000175000017500000003022610433520572013456 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_dfa.ml Copyright (c) 2005-2006, 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. *---------------------------------------------------------------------------*) module N_set = Cf_rbtree.Set(Cf_ordered.Int_order) module N_map = Cf_rbtree.Map(Cf_ordered.Int_order) let identity_ x = x module type Symbol_T = sig type t and 'a map val map: (t -> 'a) -> 'a map val get: 'a map -> t -> 'a end module type T = sig module S: Symbol_T type x type 'a r type 'a t = (S.t, 'a) Cf_parser.t val nil: x module type Expr_Op_T = sig val ( $| ): x -> x -> x val ( $& ): x -> x -> x val ( !* ): x -> x val ( !+ ): x -> x val ( !? ): x -> x val ( !: ): S.t -> x val ( !^ ): (S.t -> bool) -> x val ( !~ ): S.t Cf_seq.t -> x end module Expr_Op: Expr_Op_T module type Op_T = sig include Expr_Op_T val ( $= ): x -> 'a -> 'a r val ( $> ): x -> (S.t Cf_seq.t -> 'a) -> 'a r val ( $@ ): x -> (int -> 'a t) -> 'a r val ( !@ ): 'a r list -> 'a r end module Op: Op_T val create: 'a r -> 'a t module X: sig type ('c, 'a) r constraint 'c = S.t #Cf_parser.cursor type ('c, 'a) t = ('c, S.t, 'a) Cf_parser.X.t constraint 'c = S.t #Cf_parser.cursor module type Op_T = sig include Expr_Op_T val ( $= ): x -> 'a -> ('c, 'a) r val ( $> ): x -> (S.t Cf_seq.t -> 'a) -> ('c, 'a) r val ( $@ ): x -> (int -> ('c, 'a) t) -> ('c, 'a) r val ( !@ ): ('c, 'a) r list -> ('c, 'a) r end module Op: Op_T val create: ('c, 'a) r -> ('c, 'a) t end end module Create(S: Symbol_T) = struct module S = S class virtual ['i, 'o] satisfier state = object(_:'self) constraint 'f = int -> ('i, 'o) Cf_parser.t val state_ = state method state = state_ method follow u = {< state_ = N_set.union state_ u >} method virtual edge: S.t -> N_set.t -> N_set.t method accept = (None : 'f option) end let literal_ c = object inherit ['i, 'o] satisfier N_set.nil method edge n u = if n = c then N_set.union state_ u else u end let mapped_ f = object inherit ['i, 'o] satisfier N_set.nil method edge n u = if f n then N_set.union state_ u else u end type 's y = { y_counter_: int; y_first_: N_set.t; y_last_: N_set.t; y_follow_: 's N_map.t -> 's N_map.t; } constraint 's = ('i, 'o) #satisfier type 's w = { w_null_: bool; w_cons_: int -> 's y; } type x = (Obj.t, Obj.t) satisfier w let nil = { w_null_ = true; w_cons_ = fun i -> { y_counter_ = i; y_first_ = N_set.nil; y_last_ = N_set.nil; y_follow_ = identity_; } } let expr_ n = { w_null_ = false; w_cons_ = fun i -> let s = N_set.singleton i in { y_counter_ = succ i; y_first_ = s; y_last_ = s; y_follow_ = fun m -> N_map.replace (i, n) m; } } module type Expr_Op_T = sig val ( $| ): x -> x -> x val ( $& ): x -> x -> x val ( !* ): x -> x val ( !+ ): x -> x val ( !? ): x -> x val ( !: ): S.t -> x val ( !^ ): (S.t -> bool) -> x val ( !~ ): S.t Cf_seq.t -> x end module Expr_Op = struct let ( $| ) wa wb = { w_null_ = wa.w_null_ || wb.w_null_; w_cons_ = fun i -> let ya = wa.w_cons_ i in let yb = wb.w_cons_ ya.y_counter_ in { y_counter_ = yb.y_counter_; y_first_ = N_set.union ya.y_first_ yb.y_first_; y_last_ = N_set.union ya.y_last_ yb.y_last_; y_follow_ = fun m -> yb.y_follow_ (ya.y_follow_ m); } } let follow_fold_aux_ a m i = N_map.replace (i, let sat = N_map.search i m in sat#follow a) m let ( $& ) wa wb = { w_null_ = wa.w_null_ && wb.w_null_; w_cons_ = fun i -> let ya = wa.w_cons_ i in let yb = wb.w_cons_ ya.y_counter_ in let first = if wa.w_null_ then N_set.union ya.y_first_ yb.y_first_ else ya.y_first_ and last = if wb.w_null_ then N_set.union ya.y_last_ yb.y_last_ else yb.y_last_ in { y_counter_ = yb.y_counter_; y_first_ = first; y_last_ = last; y_follow_ = fun m -> let m = yb.y_follow_ (ya.y_follow_ m) in N_set.fold (follow_fold_aux_ yb.y_first_) m ya.y_last_ } } let star_follow_ y m = N_set.fold (follow_fold_aux_ y.y_first_) (y.y_follow_ m) y.y_last_ let ( !* ) w = { w_null_ = true; w_cons_ = fun i -> let y = w.w_cons_ i in { y with y_follow_ = star_follow_ y } } let ( !? ) x = x $| nil let ( !+ ) x = x $& (!* x) let ( !: ) i = expr_ (literal_ i) let ( !^ ) f = expr_ (mapped_ f) let rec ( !~ ) s = match Lazy.force s with | Cf_seq.Z -> nil | Cf_seq.P (hd, tl) -> !:hd $& !~tl end let acceptor_ f = object(self:'self) inherit ['i, 'o] satisfier N_set.nil method edge _ u = u method follow _ = (self :> 'self) method accept = Some f end type 'a r = (S.t, 'a) satisfier w type 'a t = (S.t, 'a) Cf_parser.t module type Op_T = sig include Expr_Op_T val ( $= ): x -> 'a -> 'a r val ( $> ): x -> (S.t Cf_seq.t -> 'a) -> 'a r val ( $@ ): x -> (int -> 'a t) -> 'a r val ( !@ ): 'a r list -> 'a r end module Op = struct include Expr_Op let ( $= ) x k = let f n z = Some (k, Cf_seq.shift n z) in (Obj.magic x) $& (expr_ (acceptor_ f)) let ( $> ) x f = let g n z = let hd = Cf_seq.limit n z and tl = Cf_seq.shift n z in Some (f hd, tl) in (Obj.magic x) $& (expr_ (acceptor_ g)) let ( $@ ) x f = (Obj.magic x) $& (expr_ (acceptor_ f)) let ( !@ ) = let rec f e = function hd :: tl -> f (hd $| e) tl | [] -> e in fun s -> f nil s end module S_order = struct type t = int array let compare = compare (* let to_string a = let b = Buffer.create 40 in Buffer.add_string b "[|"; begin match Array.length a with | 0 -> () | 1 -> Buffer.add_string b (Printf.sprintf " %u" a.(0)) | n -> for i = 0 to n - 2 do Buffer.add_string b (Printf.sprintf " %u;" a.(i)) done; Buffer.add_string b (Printf.sprintf " %u" a.(n - 1)) end; Buffer.add_string b " |]"; Buffer.contents b *) end module S_map = Cf_rbtree.Map(S_order) type ('i, 'o) s = { s_id_: S_order.t; s_accept_: (int -> ('i, 'o) Cf_parser.t) option; s_next_: ('i, 'o) s option Lazy.t S.map; } let create_aux_ = let suspend w = let y = w.w_cons_ 0 in let m = y.y_follow_ N_map.nil in let edge n u p = let sat = N_map.search p m in sat#edge n u in let rec accept u ul i = if i < ul then begin let sat = N_map.search (Array.unsafe_get u i) m in match sat#accept with | None -> accept u ul (succ i) | v -> v end else None in let sh = ref S_map.nil in let rec state u = let s = { s_id_ = u; s_accept_ = accept u (Array.length u) 0; s_next_ = S.map (follow u); } in sh := S_map.replace (u, s) !sh; s and follow u n = lazy begin let v = Array.fold_left (edge n) N_set.nil u in if N_set.empty v then None else let u = Array.of_list (N_set.to_list_incr v) in Some (try S_map.search u !sh with Not_found -> state u) end in state (Array.of_list (N_set.to_list_incr y.y_first_)) in let nil _ _ = None in let rec loop code s f n z0 z = let f = match s.s_accept_ with None -> f | Some f -> f in match Lazy.force z with | Cf_seq.Z -> f n z0 | Cf_seq.P (hd, tl) -> match Lazy.force (S.get s.s_next_ (code hd)) with | None -> f n z0 | Some s -> loop code s f (succ n) z0 tl in fun code r -> let s = suspend r in fun z -> loop code s nil 0 z z let create r = create_aux_ identity_ r module X = struct type ('c, 'a) r = (S.t * 'c, 'a) satisfier w constraint 'c = S.t #Cf_parser.cursor type ('c, 'a) t = ('c, S.t, 'a) Cf_parser.X.t constraint 'c = S.t #Cf_parser.cursor module type Op_T = sig include Expr_Op_T val ( $= ): x -> 'a -> ('c, 'a) r val ( $> ): x -> (S.t Cf_seq.t -> 'a) -> ('c, 'a) r val ( $@ ): x -> (int -> ('c, 'a) t) -> ('c, 'a) r val ( !@ ): ('c, 'a) r list -> ('c, 'a) r end module Op: Op_T = struct include Expr_Op let ( $> ) x f = let g n z = let hd = Cf_seq.limit n (Cf_seq.map fst z) and tl = Cf_seq.shift n z in Some (f hd, tl) in (Obj.magic x) $& (expr_ (acceptor_ g)) let ( $= ) = Op.( $= ) let ( $@ ) = Op.( $@ ) let ( !@ ) = Op.( !@ ) end let create r = create_aux_ fst r end end (*--- End of File [ cf_dfa.ml ] ---*) cf-0.10/cf_dfa.mli0000644000175000017500000002321110433520572013623 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_xdfa.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** Functional composition of lazy deterministic finite automata. *) (** {6 Overview} This module implements operators for functional composition of lazy deterministic finite automata (DFA). A lazy DFA is more efficient at recognizing regular grammars than a non-deterministic finite automaton, and the lazy evaluation amortizes the cost of compiling the state table so that it compares well to that of the NFA. The interface defined here is used as the underlying algorithm for the {!Cf_lex} module. It uses a functor that operates on a module defining the type of a symbol, the type of parser input tokens that contain such symbols, and a map of symbols to some polymorphic type. The result of the functor is a module that contains operator functions for composing expressions and rules for automata that operate on streams of the input symbol type. {b Note}: a DFA can be remarkably inefficient compared to an NFA for certain classes of unusual grammars and unusual input. *) (** {6 Module Types} *) (** The type of the input module for [Create(S: Symbol_T)] functor defined below. *) module type Symbol_T = sig (** The symbol type *) type t (** The type of maps from symbols to polymorphic types. *) type 'a map (** The engine uses [map f] to construct a map from symbols to state transitions. *) val map: (t -> 'a) -> 'a map (** The engine uses [get m s] to get the state transition from map [m] for the symbol [s]. *) val get: 'a map -> t -> 'a end (** The output of the [Create(S: Symbol_T)] functor, which is a module that can be used to compose deterministic finite automata which operate on symbols of the type specified. *) module type T = sig (** The module used as the input to the [Create(S: Symbol_T)] functor. *) module S: Symbol_T (** The type of an expression in the regular grammar of an automaton. *) type x (** The type of a rule for recognizing a sequence of symbols according to the regular grammar of an automaton and producing an output token. *) type 'a r (** A parser that works on the symbols used in the automaton. *) type 'a t = (S.t, 'a) Cf_parser.t (** The expression that matches the empty symbol sequence. *) val nil: x (** The signature of modules containing operators for composing DFA expressions. *) module type Expr_Op_T = sig (** Use [a $| b] to compose an expression that matches either [a] or [b] in the symbol stream. *) val ( $| ): x -> x -> x (** Use [a $& b] to compose an expression that matches [a] followed by [b] in the symbol stream. *) val ( $& ): x -> x -> x (** Use [!*a] to compose an expression that matches zero or more occurances of [a] in the symbol stream. *) val ( !* ): x -> x (** Use [!+a] to compose an expression that matches one or more occurances of [a] in the symbol stream. *) val ( !+ ): x -> x (** Use [!?a] to compose an expression that matches zero or one occurance of [a] in the symbol stream. *) val ( !? ): x -> x (** Use [!:sym] to compose an expression that matches the symbol [sym] in the symbol stream. *) val ( !: ): S.t -> x (** Use [!^f] to compose an expression that matches any symbol in the symbol stream for which applying the function [f] returns [true]. *) val ( !^ ): (S.t -> bool) -> x (** Use [!~z] to compose an expression that matches the sequence of symbols [z] in the symbol stream. *) val ( !~ ): S.t Cf_seq.t -> x end (** The module containing the expression operators. *) module Expr_Op: Expr_Op_T (** The signature of the [Op] module, which contains the composition operators. *) module type Op_T = sig include Expr_Op_T (** Use [e $= x] to compose a rule that produces [x] when the symbols in the symbol stream match the expression [e]. *) val ( $= ): x -> 'a -> 'a r (** Use [e $> f] to compose a rule that applies the tokenizer function [f] to the sequence of input symbols in the stream recognized by the expression [e] to produce an output token. *) val ( $> ): x -> (S.t Cf_seq.t -> 'a) -> 'a r (** Use [e $@ f] to compose a rule that applies the scanning function [f] to the input stream when it is recognized by the expression [e]. The scanning function is passed the length of the recognized sequence of symbols and receives a parser in return that produces the output of the rule and makes any advanced manipulations of the input stream necessary to continue parsing for the next token. If the parser returned from the scanning function does not recognize the input stream, then the rule is not matched and the next best matching rule is selected. *) val ( $@ ): x -> (int -> 'a t) -> 'a r (** Use this operator to combine a list of rules into a single rule. *) val ( !@ ): 'a r list -> 'a r end (** Open this module to bring the composition operators into the current scope. *) module Op: Op_T (** Use [create r] to construct a parser that recognizes the longest sequence that matches the rule [r]. *) val create: 'a r -> 'a t (** A module of extensions for working with input sequences that require position information in the parse function. *) module X: sig (** The type of a rule for recognizing a sequence of symbols in a stream woven with a cursor stream and according to the regular grammar of an automaton and producing an output token. *) type ('c, 'a) r constraint 'c = S.t #Cf_parser.cursor (** An extended parser that works on pairs of symbols and cursor objects and used in the automaton. *) type ('c, 'a) t = ('c, S.t, 'a) Cf_parser.X.t constraint 'c = S.t #Cf_parser.cursor (** The signature of the [Op] module, which contains the composition operators. *) module type Op_T = sig include Expr_Op_T (** Use [e $= x] to compose a rule that produces [x] when the symbols in the symbol stream match the expression [e]. *) val ( $= ): x -> 'a -> ('c, 'a) r (** Use [e $> f] to compose a rule that applies the tokenizer function [f] to the sequence of input symbols in the symbol/cursor stream recognized by the expression [e] to produce an output token. *) val ( $> ): x -> (S.t Cf_seq.t -> 'a) -> ('c, 'a) r (** Use [e $@ f] to compose a rule that applies the scanning function [f] to the symbol/cursor input stream when the symbol sequence is recognized by the expression [e]. This operator performs the same function as the [( $@ )] operator, but it works on a stream of symbols woven with a corresponding cursor stream. *) val ( $@ ): x -> (int -> ('c, 'a) t) -> ('c, 'a) r (** Use this operator to combine a list of "cursor woven" rules into a single rule. *) val ( !@ ): ('c, 'a) r list -> ('c, 'a) r end (** Open this module to bring the composition operators into the current scope. *) module Op: Op_T (** Use [create r] to construct a parser that recognizes the longest sequence that matches the rule [r]. *) val create: ('c, 'a) r -> ('c, 'a) t end end (** The functor that creates a DFA module. *) module Create(S: Symbol_T): T with module S = S (*--- End of File [ cf_xdfa.mli ] ---*) cf-0.10/cf_either.ml0000644000175000017500000000313210433520572014200 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_either.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) type ('a, 'b) t = A of 'a | B of 'b (*--- End of File [ cf_either.ml ] ---*) cf-0.10/cf_either.mli0000644000175000017500000000335510433520572014360 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_either.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** A utility type to represent the sum of two parameter types. This is used in some of the more arcane operators in the {!Cf_flow} module. *) type ('a, 'b) t = A of 'a | B of 'b (*--- End of File [ cf_either.mli ] ---*) cf-0.10/cf_exnopt.ml0000644000175000017500000000312510433520572014237 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_exnopt.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) type 'a t = U of 'a | X of exn (*--- End of File [ cf_exnopt.ml ] ---*) cf-0.10/cf_exnopt.mli0000644000175000017500000000323710433520572014414 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_exnopt.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** A utility type representing the sum of a parameter and an exception. *) type 'a t = U of 'a | X of exn (*--- End of File [ cf_exnopt.mli ] ---*) cf-0.10/cf_flow.ml0000644000175000017500000002177710433520572013706 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_flow.ml Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) type ('i, 'o) t = ('i, 'o) cell Lazy.t and ('i, 'o) cell = P of 'o * ('i,'o) t | Q of ('i -> ('i, 'o) cell) | Z let nil = lazy Z let rec nop = lazy (Q (fun x -> P (x, nop))) let rec filter f = let rec loop x = if f x then P (x, filter f) else Q loop in Lazy.lazy_from_val (Q loop) let rec map f = Lazy.lazy_from_val (Q (fun x -> P (f x, map f))) let rec optmap f = let rec loop x = match f x with | Some y -> P (y, optmap f) | None -> Q loop in Lazy.lazy_from_val (Q loop) let rec listmap f = let rec outer x = inner (listmap f) (f x) and inner w = function | hd :: tl -> P (hd, lazy (inner w tl)) | [] -> Lazy.force w in Lazy.lazy_from_val (Q outer) let rec put_seq_ w s = match Lazy.force s with | Cf_seq.P (hd, tl) -> P (hd, lazy (put_seq_ w tl)) | Cf_seq.Z -> Lazy.force w let rec seqmap f = let rec loop x = put_seq_ (seqmap f) (f x) in Lazy.lazy_from_val (Q loop) let broadcast = let rec loop fs = function | hd :: tl -> begin match Lazy.force hd with | Z -> loop fs tl | P (y, next) -> P (y, lazy (loop fs (next :: tl))) | Q f -> loop (f :: fs) tl end | [] -> match fs with | [] -> Z | fs -> Q (fun x -> loop [] (List.rev_map (fun f -> lazy (f x)) fs)) in fun ws -> lazy (loop [] ws) let rec mapstate f s = lazy (Q (fun x -> let s, y = f s x in P (y, mapstate f s))) let rec machine f = let loop s x = match f s x with | Some (s, out) -> put_seq_ (machine f s) out | None -> Z in fun s -> lazy (Q (loop s)) module Op = struct let ( -*- ) = let rec loop w1 w2 = match Lazy.force w1 with | Z -> Lazy.force w2 | P (hd, tl) -> P (hd, lazy (loop tl w2)) | Q f1 as w1cell -> match Lazy.force w2 with | Z -> w1cell | P (hd, tl) -> P (hd, lazy (loop w1 tl)) | Q f2 -> Q begin fun x -> let w1 = Lazy.lazy_from_val (f1 x) in let w2 = lazy (f2 x) in loop w1 w2 end in fun w1 w2 -> lazy (loop w1 w2) let ( -=- ) = let rec loop w1 w2 = match Lazy.force w2 with | Z -> Z | P (hd, tl) -> P (hd, lazy (loop w1 tl)) | Q f -> match Lazy.force w1 with | Z -> Z | P (hd, tl) -> loop tl (lazy (f hd)) | Q f -> Q (fun x -> loop (Lazy.lazy_from_val (f x)) w2) in fun w1 w2 -> lazy (loop w1 w2) let ( -&- ) = let rec loop w1 w2 = match Lazy.force w1 with | Z -> Lazy.force w2 | P (hd, tl) -> P (hd, lazy (loop tl w2)) | Q f -> Q (fun x -> loop (Lazy.lazy_from_val (f x)) w2) in fun w1 w2 -> lazy (loop w1 w2) let rec ( ~@ ) = let rec loop q w = match Lazy.force w with | Z -> Z | P (hd, tl) -> P (hd, lazy (loop (Cf_deque.A.push hd q) tl)) | Q f -> match Cf_deque.B.pop q with | Some (hd, tl) -> loop tl (Lazy.lazy_from_val (f hd)) | None -> Q (fun x -> loop q (lazy (f x))) in fun w -> lazy (loop Cf_deque.nil w) let consA_ a = Cf_either.A a let consB_ b = Cf_either.B b let stripA_ = function Cf_either.A a -> Some a | _ -> None let stripB_ = function Cf_either.B b -> Some b | _ -> None let ( -+- ) s0 s1 = let s0 = optmap stripA_ -=- s0 -=- map consA_ and s1 = optmap stripB_ -=- s1 -=- map consB_ in s0 -*- s1 let stripBorAA_ = function | Cf_either.B _ as v | Cf_either.A (Cf_either.A _ as v) -> Some v | _ -> None let stripAB_ = function | Cf_either.A (Cf_either.B x) -> Some x | _ -> None let ( ~@< ) s = let s' = optmap stripBorAA_ -=- s -=- map consA_ in map consB_ -=- ~@ s' -=- optmap stripAB_ let pre_ = function | Cf_either.B x -> Cf_either.B (Cf_either.B x) | Cf_either.A (Cf_either.A x) -> Cf_either.A x | Cf_either.A (Cf_either.B x) -> Cf_either.B (Cf_either.A x) let post_ = function | Cf_either.B (Cf_either.B x) -> Cf_either.B x | Cf_either.B (Cf_either.A x) -> Cf_either.A (Cf_either.A x) | Cf_either.A x -> Cf_either.A (Cf_either.B x) let ( -@- ) s1 s0 = ~@< (map pre_ -=- (s0 -+- s1) -=- map post_) end open Op let to_seq = let rec loop w = match Lazy.force w with | Z -> Cf_seq.Z | P (hd, tl) -> Cf_seq.P (hd, lazy (loop tl)) | Q f -> loop (lazy (f ())) in fun w -> lazy (loop w) let of_seq = let rec loop s = match Lazy.force s with | Cf_seq.P (hd, tl) -> P (hd, lazy (loop tl)) | Cf_seq.Z -> Z in fun s -> lazy (loop s) let delta_ = (int_of_char 'a') - (int_of_char 'A') let upcase = map begin function | 'a'..'z' as c -> char_of_int ((int_of_char c) - delta_) | c -> c end let dncase = map begin function | 'A'..'Z' as c -> char_of_int ((int_of_char c) + delta_) | c -> c end let rec commute = let rec loop w s = match Lazy.force w with | Z -> Cf_seq.Z | P (hd, tl) -> Cf_seq.P (hd, commute tl s) | Q f -> match Lazy.force s with | Cf_seq.P (hd, tl) -> loop (Lazy.lazy_from_val (f hd)) tl | Cf_seq.Z -> Cf_seq.Z in fun w s -> lazy (loop w s) let commute_string w s = Cf_seq.to_string (commute w (Cf_seq.of_string s)) let drain = let rec loop w = match Lazy.force w with | P (hd, tl) -> Cf_seq.P (hd, lazy (loop tl)) | _ -> Cf_seq.Z in fun w -> lazy (loop w) let flush = let rec loop w = match Lazy.force w with | P (_, tl) -> loop tl | w -> w in fun w -> lazy (loop w) let rec ingestor = let rec loop = function | None -> Z | Some s -> match Lazy.force s with | Cf_seq.Z -> Q loop | Cf_seq.P (hd, tl) -> P (hd, lazy (loop (Some tl))) in lazy (Q loop) let rec transcode_drain_ w = match Lazy.force w with | Z -> Cf_seq.Z | P (hd, tl) -> Cf_seq.P (hd, lazy (transcode_drain_ tl)) | Q f -> transcode_drain_ (lazy (f None)) let transcode = let rec loop (w : ('i Cf_seq.t option, 'o) t) (s : 'i Cf_seq.t) = match Lazy.force w with | Z -> Cf_seq.Z | P (hd, tl) -> Cf_seq.P (hd, lazy (loop tl s)) | Q f -> transcode_drain_ (lazy (f (Some s))) in fun w s -> lazy (loop w s) module Transcode = struct let more w s = match Lazy.force w with | Z -> Cf_seq.nil, w | P (_, _) -> drain w, flush w | Q f -> let w = lazy (f (Some s)) in drain w, flush w let last w = match Lazy.force w with | Z -> Cf_seq.nil | P (_, _) -> drain w | Q f -> drain (lazy (f None)) end let finishC_ _ = Lazy.lazy_from_val Z let finishSC_ _ _ = Lazy.lazy_from_val Z let readC f = lazy (Q (fun a -> Lazy.force (f a))) let writeC o f = lazy (P (o, f ())) let evalC m = m finishC_ let readSC f s = lazy (Q (fun a -> Lazy.force (f a s))) let writeSC o f s = lazy (P (o, f () s)) let evalSC m s = m finishSC_ s (*--- End of File [ cf_flow.ml ] ---*) cf-0.10/cf_flow.mli0000644000175000017500000002225010433520572014042 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_flow.mli Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) (** Lazy stream procesors and their operators. *) (** {6 Overview} A [Cf_flow] value is like a [Cf_seq] value that can take intermediate input to continue generating output. Many of the other modules in the [cf] library use this module. The semantics of this module are derived from the stream processors in the Fudgets system, as described by Magnus Carlsson and Thomas Hallgren in their joint {{:http://www.cs.chalmers.se/~hallgren/Thesis/}Ph.D. thesis}, chapter 16. *) (** {6 Types} *) (** A stream processor *) type ('i, 'o) t = ('i, 'o) cell Lazy.t and ('i, 'o) cell = | P of 'o * ('i,'o) t (** Output a value *) | Q of ('i -> ('i, 'o) cell) (** Input a value *) | Z (** Finish processing stream *) (** {6 Constructors} *) (** A stream processor that reads no input and writes no output. *) val nil: ('y, 'x) t (** A stream processor that outputs every input value without change. *) val nop: ('x, 'x) t (** Use [filter f] to construct a stream processor that applies [f] to every input value and outputs only those for which the function result is [true]. *) val filter: ('x -> bool) -> ('x, 'x) t (** Use [map f] to construct a stream processor that applies [f] to every input value and outputs the result. *) val map: ('i -> 'o) -> ('i, 'o) t (** Use [optmap f] to construct a stream processor that applies [f] to every input value and outputs the result if there is one. *) val optmap: ('i -> 'o option) -> ('i, 'o) t (** Use [listmap f] to construct a stream processor that applies [f] to every input value and outputs every element of the resulting list. *) val listmap: ('i -> 'o list) -> ('i, 'o) t (** Use [listmap f] to construct a stream processor that applies [f] to every input value and outputs every element of the resulting sequence. *) val seqmap: ('i -> 'o Cf_seq.t) -> ('i, 'o) t (** Use [broadcast ws] to construct a stream processor that combines the input and output of every stream processor in the list [ws] by first rendering all the output from each stream in turn, then ingesting all the input to each stream in turn, until all streams are completed. *) val broadcast: ('i, 'o) t list -> ('i, 'o) t (** Use [mapstate f s] with an initial state value [s] and a folding function [f] to construct a stream processor that folds the state into every input value to produce an output value and a new state. *) val mapstate: ('s -> 'i -> 's * 'o) -> 's -> ('i, 'o) t (** Use [machine f s] with an initial state value [s] and a folding function [f] to construct a stream processor that folds the state into every input value to produce either a sequence of values to output and a new state or the end of stream processing. *) val machine: ('s -> 'i -> ('s * 'o Cf_seq.t) option) -> 's -> ('i, 'o) t (** {6 Operators} *) (** Open this module to bring the operator functions into the current scope. *) module Op: sig (** Broadcasting parallel composition. *) val ( -*- ): ('i, 'o) t -> ('i, 'o) t -> ('i, 'o) t (** Serial composition. *) val ( -=- ): ('i, 'x) t -> ('x, 'o) t -> ('i, 'o) t (** Sequential composition. *) val ( -&- ): ('i, 'o) t -> ('i, 'o) t -> ('i, 'o) t (** Tagged parallel composition. *) val ( -+- ): ('ia, 'oa) t -> ('ib, 'ob) t -> (('ia, 'ib) Cf_either.t, ('oa, 'ob) Cf_either.t) t (** Serial loop composition. *) val ( ~@ ): ('x, 'x) t -> ('x, 'x) t (** Serial loop left. *) val ( ~@< ): (('x, 'i) Cf_either.t, ('x, 'o) Cf_either.t) t -> ('i, 'o) t (** Serial loop through right. *) val ( -@- ): (('o0, 'i1) Cf_either.t, ('i0, 'o1) Cf_either.t) t -> ('i0, 'o0) t -> ('i1, 'o1) t end (** {6 Miscellaneous} *) (** Use [to_seq w] to convert a stream processor [w] into the equivalent sequence. This can only work when the stream processor ingests input of the [unit] type. *) val to_seq: (unit, 'o) t -> 'o Cf_seq.t (** Use [of_seq z] to convert a sequence into the equivalent stream processor (which never ingests any input). *) val of_seq: 'o Cf_seq.t -> ('i, 'o) t (** A stream processor that converts uppercase US-ASCII characters into lowercase characters. All other characters are unchanged. *) val upcase: (char, char) t (** A stream processor that converts lowercase US-ASCII characters into uppercase characters. All other characters are unchanged. *) val dncase: (char, char) t (** Use [commute w z] to produce an output sequence from a flow [w] that ingests its input from the sequence [z]. *) val commute: ('i, 'o) t -> 'i Cf_seq.t -> 'o Cf_seq.t (** Use [commute_string w s] to commute the sequence of characters in the string [s] with the flow [w] and compose a new string from the resulting sequence. *) val commute_string: (char, char) t -> string -> string (** Use [drain w] to produce an output sequence comprised of all the values output from the stream processor [w] until the first input is required. *) val drain: ('i, 'o) t -> 'o Cf_seq.t (** Use [flush w] to discard all the output from the flow [w] until the first input is required. *) val flush: ('i, 'o) t -> ('i, 'o) t (** A stream processor that copies to its output every element of its input sequences. The stream processor finishes when it ingests [None]. This stream processor is helpful for placing at the end of a serial composition to produce a transcoder. *) val ingestor: ('a Cf_seq.t option, 'a) t (** Use [transcode w z] to produce the sequence of output values obtained by executing the transcoder stream processor [w] to ingest every element of the sequence [z]. *) val transcode: ('i Cf_seq.t option, 'o) t -> 'i Cf_seq.t -> 'o Cf_seq.t (** A namespace for the [more] and [last] transcoder functions. *) module Transcode: sig (** Use [more w z] to produce an intermediate sequence of output values obtained by executing the transcoder stream processor [w] to ingest all the elements of the sequence [z]. Returns the intermediate output sequence and a new transcoder stream processor representing the intermediate state of the transcoder, as it is now ready for ingesting more input or its "end of input" indication. *) val more: ('i Cf_seq.t option, 'o) t -> 'i Cf_seq.t -> 'o Cf_seq.t * ('i Cf_seq.t option, 'o) t (** Use [last w z] to produce the final sequence of output values obtained by executing the transcoder stream processor [w] after ingesting the "end of input" indication. *) 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 ] ---*) cf-0.10/cf_gadget.ml0000644000175000017500000002224110731665257014170 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_gadget.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (*** CAN WE MAKE THIS A PURE FUNCTIONAL IMPLEMENTATION? ***) module IMap = Cf_rbtree.Map(Cf_ordered.Int_order) type wref = Wire of int * wref Weak.t * string option type ('i, 'o, 'a) t = (('i, 'o) work, 'a) Cf_cmonad.t and ('i, 'o) work = (('i, 'o) state, ('i, 'o) Cf_flow.t, unit) Cf_scmonad.t and ('i, 'o) gate = (wref * (Obj.t -> ('i, 'o, unit) t)) Cf_seq.t and ('i, 'o) state = { wireN: int; freeWireQ: int Cf_deque.t; wirePtrQ: (int * wref Weak.t) Cf_deque.t; msgQM: Obj.t Cf_deque.t IMap.t; readyQ: ('i, 'o) work Cf_deque.t; guardQ: ('i, 'o) gate Cf_deque.t; inputQ: ('i -> ('i, 'o) work) Cf_deque.t; } type ('x, 'i, 'o) wire = wref * wref type ('i, 'o, 'a) guard = (('i, 'o) gate, 'a) Cf_cmonad.t open Cf_scmonad.Op type void = Void type ('i, 'o) gateloop = | L_ready of Obj.t Cf_deque.t IMap.t * ('i, 'o) work | L_pending of ('i, 'o) gate | L_discard let rec scheduler_ Void = Cf_scmonad.load >>= fun k -> let m, gQ, rQ = guardLoop_ k.msgQM k.guardQ Cf_deque.nil Cf_deque.nil in let run work rQ i = let k = { k with msgQM = m; readyQ = rQ; guardQ = gQ; inputQ = i } in Cf_scmonad.store k >>= fun () -> work in let rQ = Cf_deque.catenate rQ k.readyQ in match Cf_deque.B.pop rQ with | Some (hd, tl) -> run hd tl k.inputQ | None -> match Cf_deque.B.pop k.inputQ with | None -> Cf_scmonad.nil | Some (input, inputQ) -> Cf_flow.readSC >>= fun i -> let work = input i in let rQ = Cf_deque.map (fun f -> f i) inputQ in run work rQ Cf_deque.nil and guardLoop_ m gQ gQ' rQ' = match Cf_deque.B.pop gQ with | None -> m, gQ', rQ' | Some (hd, tl) -> match gateLoop_ m hd Cf_deque.nil with | L_ready (m, r) -> guardLoop_ m tl gQ' (Cf_deque.A.push r rQ') | L_pending g -> guardLoop_ m tl (Cf_deque.B.push g gQ') rQ' | L_discard -> guardLoop_ m tl gQ' rQ' and gateLoop_ m z q = match Lazy.force z with | Cf_seq.Z when Cf_deque.empty q -> L_discard | Cf_seq.Z -> L_pending (Cf_deque.B.to_seq q) | Cf_seq.P ((Wire (n, ptr, _), f as g), z) -> match try Some (IMap.extract n m) with Not_found -> None with | Some (q, m) -> assert (not (Cf_deque.empty q)); let msg = Cf_deque.B.head q in let q = Cf_deque.B.tail q in let m = if Cf_deque.empty q then m else IMap.replace (n, q) m in let work = Cf_cmonad.eval (f msg) (scheduler_ Void) in L_ready (m, work) | None -> gateLoop_ m z (if Weak.check ptr 0 then Cf_deque.A.push g q else q) let state0_ = { wireN = 1; freeWireQ = Cf_deque.nil; wirePtrQ = Cf_deque.nil; msgQM = IMap.nil; readyQ = Cf_deque.nil; guardQ = Cf_deque.nil; inputQ = Cf_deque.nil; } let eval m = Cf_cmonad.eval begin Cf_cmonad.Op.( >>= ) (Cf_scmonad.down (Cf_cmonad.eval m (scheduler_ Void)) state0_) (fun _ -> Cf_cmonad.nil) end Cf_flow.nil let start m c = let work = Cf_cmonad.eval m (scheduler_ Void) in Cf_scmonad.modify begin fun k -> { k with readyQ = Cf_deque.A.push work k.readyQ } end >>= c let guard m _ = let guard = Cf_cmonad.eval m Cf_seq.nil in Cf_scmonad.modify begin fun k -> { k with guardQ = Cf_deque.A.push guard k.guardQ } end >>= fun () -> scheduler_ Void let abort _ = scheduler_ Void let wireAux0_ ?id n = let rxPtr = Weak.create 1 and txPtr = Weak.create 1 in let rx = Wire (n, txPtr, id) and tx = Wire (n, txPtr, id) in Weak.set rxPtr 0 (Some tx); Weak.set txPtr 0 (Some rx); rx, tx let wireAux1_ ?id wireN freeWireQ wirePtrQ = match Cf_deque.B.pop freeWireQ with | Some (n, q) -> wireN, q, wirePtrQ, wireAux0_ ?id n | None -> let n = wireN in let rx, tx as wire = wireAux0_ ?id n in let ptr = Weak.create 2 in Weak.set ptr 0 (Some rx); Weak.set ptr 1 (Some tx); let wirePtrQ = Cf_deque.A.push (n, ptr) wirePtrQ in succ n, freeWireQ, wirePtrQ, wire let wireAux_ ?id c = Cf_scmonad.load >>= fun k -> let { wireN = n; freeWireQ = fQ; wirePtrQ = pQ } = k in let n, fQ, pQ, wire = wireAux1_ ?id n fQ pQ in let k = { k with wireN = n; freeWireQ = fQ; wirePtrQ = pQ } in Cf_scmonad.store k >>= fun () -> c wire let wirepairAux_ ?id c = Cf_scmonad.load >>= fun k -> let { wireN = n; freeWireQ = fQ; wirePtrQ = pQ } = k in let n, fQ, pQ, wire1 = wireAux1_ ?id n fQ pQ in let n, fQ, pQ, wire2 = wireAux1_ ?id n fQ pQ in let k = { k with wireN = n; freeWireQ = fQ; wirePtrQ = pQ } in Cf_scmonad.store k >>= fun () -> c (wire1, wire2) let wire c = wireAux_ c let wirepair c = wirepairAux_ c let nullAux_ = Wire (0, Weak.create 1, Some "null") let null c = c (nullAux_, nullAux_) let read f = Cf_scmonad.modify begin fun k -> { k with inputQ = Cf_deque.A.push f k.inputQ } end >>= fun () -> scheduler_ Void let write x c = Cf_flow.writeSC x >>= c let rxGet_ (Wire (_, txPtr, _) as wref) f c = if Weak.check txPtr 0 then begin let f: Obj.t -> ('i, 'o, unit) t = Obj.magic f in Cf_seq.writeC (wref, f) c end else c () let txPut_ (Wire (n, rxPtr, _)) x c = if Weak.check rxPtr 0 then begin Cf_scmonad.modify begin fun k -> let m = let x = Obj.repr x in try IMap.modify n (Cf_deque.A.push x) k.msgQM with | Not_found -> IMap.replace (n, Cf_deque.A.push x Cf_deque.nil) k.msgQM in let rQ = Cf_deque.A.push (c ()) k.readyQ in { k with msgQM = m; readyQ = rQ } end >>= fun () -> scheduler_ Void end else c () class connector (Wire (n, ptr, id)) = let id = match id with | Some id -> Lazy.lazy_from_val id | None -> lazy (Printf.sprintf "wire%08u" n) in object method id = Lazy.force id method check = Weak.check ptr 0 end class ['x, 'i, 'o] rx (wref, _ : ('x, 'i, 'o) wire) = object inherit connector wref method get: ('x -> ('i, 'o, unit) t) -> ('i, 'o, unit) guard = fun f c -> rxGet_ wref f c end class ['x, 'i, 'o] tx (_, wref : ('x, 'i, 'o) wire) = object inherit connector wref method put: 'x -> ('i, 'o, unit) t = fun x c -> txPut_ wref x c end let connect m c = m (fun w -> c (new rx w, new tx w)) let simplex c = connect wire c type ('x, 'y, 'i, 'o) pad = ('x, 'i, 'o) rx * ('y, 'i, 'o) tx type ('x, 'y, 'i, 'o) fix = ('y, 'i, 'o) rx * ('x, 'i, 'o) tx let connectpair m c = let f (a, b) = c ((new rx a, new tx b), (new rx b, new tx a)) in m f let duplex c = connectpair wirepair c let wrap x y = let x = (x :> ('x, 'i, 'o) rx) in let y = (y :> ('y, 'i, 'o) tx) in let rec loop w cc = match Lazy.force w with | Cf_flow.Z -> cc () | Cf_flow.P (hd, tl) -> y#put hd (fun () -> loop tl cc) | Cf_flow.Q f -> guard (x#get (fun i -> loop (lazy (f i)))) cc in fun w -> start (loop w) class virtual ['i, 'o] next = object(self) method private virtual guard: ('i, 'o, unit) guard method next: 'a. ('i, 'o, 'a) t = guard self#guard end class virtual ['i, 'o] start = object(self) method private virtual guard: ('i, 'o, unit) guard method start: ('i, 'o, unit) t = start (guard self#guard) end let create f c = duplex (fun (x, y) -> (f x)#start (fun () -> c y)) let createM f c = duplex (fun (x, y) -> f x (fun m -> m#start (fun () -> c y))) (*--- End of File [ cf_gadget.ml ] ---*) cf-0.10/cf_gadget.mli0000644000175000017500000002567410731665257014356 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_gadget.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** Monadic composition of complex stream processors. An experimental interface for constructing interactive functional systems in a single thread of control. *) (** {6 Overview} This module implements a marginally more general version of the Gadget system described in Chapter 30 of Magnus Carlsson's and Thomas Hallgren's joint {{:http://www.cs.chalmers.se/~hallgren/Thesis/}Ph.D. thesis}. In the context of this module, a "gadget" is a monad that evaluates into a {!Cf_flow} object, capable of alternately reading from a source of input values and writing to a sink of output values. The continuation monad is specialized over an abstract "work" monad type, and a scheduler handles the calls and jumps between multiple simultaneous work units, communicating with one another over a very lightweight message passing abstraction called a "wire". The abstract work monad is a kind of state-continuation monad for operations over the internal {!Cf_flow} value. The operations it supports are lifted into the gadget monad, and they are summarized as follows: {ul {- {i start}: launch a new gadget in the scheduler.} {- {i wire}: create a new message wire.} {- {i put}: send a message on a wire.} {- {i get}: create a gate for receiving messages on a wire.} {- {i guard}: receive a message from one of several gates.} {- {i read}: read a new value from the external input.} {- {i write}: write a new value to the external output.} } 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. Any gadget may read from the internal input stream or write to the external output stream. Conventionally, it is often simpler to define a a reader gadget and a writer gadget to localize these effects. {b Note}: see Magnus Carlsson's and Thomas Hallgren's joint {{:http://www.cs.chalmers.se/~hallgren/Thesis/}Ph.D. thesis} for a complete dissertation on the nature of the system of concepts behind this module. *) (** {6 Types} *) (** An functionally compositional work unit in a gadget, encapsulating the state-continuation monad for the underlying {!Cf_flow} object. *) type ('i, 'o) work (** A gating sequence for receiving messages using the [guard] function. *) type ('i, 'o) gate (** An object capable of delivering messages of type ['x] from a sender to a a receiver in a [('i, 'o) work] continuation. *) type ('x, 'i, 'o) wire (** A guard for receiving a message from one or more sources. *) type ('i, 'o, 'a) guard = (('i, 'o) gate, 'a) Cf_cmonad.t (** A continuation monad parameterized by work unit type. *) type ('i, 'o, 'a) t = (('i, 'o) work, 'a) Cf_cmonad.t (** {6 Functions} *) (** Use [eval y] to obtain a new flow by evaluating the gadget monad [y]. *) val eval: ('i, 'o, unit) t -> ('i, 'o) Cf_flow.t (** Use [start y] to start a new gadget evaluating the gadget [y]. *) val start: ('i, 'o, unit) t -> ('i, 'o, unit) t (** Use [guard m] to receive the next message guarded by [m]. The continuation bound to the result is discarded and control passes to the scheduler. *) val guard: ('i, 'o, unit) guard -> ('i, 'o, 'a) t (** Use [abort] to abort gadgeting and return to the scheduler. This is a convenient shortcut for [guard Cf_cmonad.nil]. *) val abort: ('i, 'o, 'a) t (** Use [wire] to return a new wire for carrying messages of type ['x]. *) val wire: ('i, 'o, ('x, 'i, 'o) wire) t (** Use [wirepair] to return a pair of new wires for carrying messages of type ['x] and ['y]. *) val wirepair: ('i, 'o, ('x, 'i, 'o) wire * ('y, 'i, 'o) wire) t (** Use [null] to construct a wire that discards every message transmitted without ever delivering it. Such wires can be useful for default arguments to some gadget functions. *) val null: ('i, 'o, ('x, 'i, 'o) wire) t (** Bind [read] to get the next input value from the external stream. *) val read: ('i, 'o, 'i) t (** Bind the result of [write obj] to put the next output value into the external stream. *) val write: 'o -> ('i, 'o, unit) t (** {6 Classes} *) (** The class type of connector objects. *) class type connector = object (** Returns a string representation of the wire end identifier. *) method id: string (** Returns [true] if the other end of the wire has not yet been reclaimed by the garbage collector. *) method check: bool (** Cut the connection between the receiver and the transmitter. *) (* method cut: unit *) end (** The class of receiver objects. *) class ['x, 'i, 'o] rx: ('x, 'i, 'o) wire -> (** A wire carrying messages of type ['x]. *) object 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: ('x -> ('i, 'o, unit) t) -> ('i, 'o, unit) guard end (** The class of transmitter objects. *) class ['x, 'i, 'o] tx: ('x, 'i, 'o) wire -> (** A wire carrying messages of type ['x]. *) object inherit connector (** Use [tx#put obj] to schedule the message obj for deliver on the associated wire. *) method put: 'x -> ('i, 'o, unit) t end (** {6 Miscellaneous} *) (** Use [connect m] to construct a new matching pair of [rx] and [tx] objects from the wire returned by [m]. *) val connect: ('i, 'o, ('x, 'i, 'o) wire) t -> ('i, 'o, ('x, 'i, 'o) rx * ('x, 'i, 'o) tx) t (** Use [simplex] to construct a new matching pair of [rx] and [tx] objects. This is a convenient abbreviation of [connect wire]. *) val simplex: ('i, 'o, ('x, 'i, 'o) rx * ('x, 'i, 'o) tx) t (** A pair of convenience types for representing each end of a bundle of two wires used for duplex communication. By convention, a [pad] comprises a receiver for control events and a transmitter for notification events, and a [fix] comprises the transmitter for control events and the receiver for notification events *) type ('x, 'y, 'i, 'o) pad = ('x, 'i, 'o) rx * ('y, 'i, 'o) tx type ('x, 'y, 'i, 'o) fix = ('y, 'i, 'o) rx * ('x, 'i, 'o) tx (** Use [connectpair m] to construct a new duplex communication channel, composed with the wire pair returned by [m]. A matching [fix] and [pad] of the channel are returned. *) val connectpair: ('i, 'o, ('x, 'i, 'o) wire * ('y, 'i, 'o) wire) t -> ('i, 'o, ('x, 'y, 'i, 'o) fix * ('x, 'y, 'i, 'o) pad) t (** Use [duplex] to construct a new duplex communication channel, composed of two wires each in opposite flow. A matching [fix] and [pad] for each channel are returned. This is a convenient abbreviation of [connectpair wirepair]. *) val duplex: ('i, 'o, ('x, 'y, 'i, 'o) fix * ('x, 'y, 'i, 'o) pad) t (** Use [wrap rx tx w] to start a new gadget that wraps the flow [w], so that it reads output from the flow (copying it to [tx] object) and writes input to the flow (copying it from the [rx] object). *) val wrap: ('x, 'i, 'o) #rx -> ('y, 'i, 'o) #tx -> ('x, 'y) Cf_flow.t -> ('i, 'o, unit) t (** Use [inherit \['i, 'o\] next] to derive a class that implements an intermediate state in a machine. *) class virtual ['i, 'o] next: object('self) (** The guard evaluated by this state of the machine. *) method virtual private guard: ('i, 'o, unit) guard (** Use [obj#next] to transition the state of the gadget by applying {!Cf_state_gadget.guard} [self#guard]. *) method next: 'a. ('i, 'o, 'a) t end (** Use [inherit \['i, 'o\] start] to derive a class to represent the initial state of a machine. It's [start] method initiates the machine with the virtual private [guard] method. *) class virtual ['i, 'o] start: object('self) (** The first guard evaluationed by the machine after starting. *) method virtual private guard: ('i, 'o, unit) guard (** Starts a new gadget, i.e. [start (guard self#guard)]. *) method start: ('i, 'o, unit) t end (** Use [create f] to create a duplex channel, and apply [f] to the resulting [pad] to obtain the initial state of a machine. The machine is started and the corresponding [fix] is returned. *) val create: (('c, 'n, 'i, 'o) pad -> ('i, 'o) #start) -> ('i, 'o, ('c, 'n, 'i, 'o) fix) t (** Use [createM f] to create a duplex channel, and apply [f] to the resulting [pad] to obtain a continuation monad that evaluates to the initial state of a machine. The machine is started and the corresponding [fix] is returned. *) val createM: (('c, 'n, 'i, 'o) pad -> ('i, 'o, ('i, 'o) #start) t) -> ('i, 'o, ('c, 'n, 'i, 'o) fix) t (*--- End of File [ cf_gadget.mli ] ---*) cf-0.10/cf_gregorian.ml0000644000175000017500000001270610433520572014704 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_gregorian.ml Copyright (c) 2003-2006, 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 of_mjd = let rec loop year day = if day >= 146097 then loop (succ year) (day - 146097) else year, day in fun ?wday ?yday day -> let year = day / 146097 in let day = (day mod 146097) + 678881 in let year, day = loop year day in begin match wday with | None -> () | Some wday -> wday := (day + 3) mod 7 end; let year = year * 4 in let year, day = if day = 146096 then year + 3, 36524 else year + (day / 36524), day mod 36524 in let year = ((year * 25) + (day / 1461)) * 4 in let day = day mod 1461 in let yd = if day < 306 then 1 else 0 in let year, day = if day = 1460 then year + 3, 365 else year + (day / 365), day mod 365 in let yd = yd + day in let day = day * 10 in let month = (day + 5) / 306 in let day = (day + 5) mod 306 in let day = day / 10 in let yd, year, month = if month >= 10 then yd - 306, succ year, month - 10 else yd + 59, year, month + 2 in begin match yday with | None -> () | Some yday -> yday := yd end; year, succ month, succ day let of_cjd ?wday ?yday day = if day < (min_int + 2400001) then invalid_arg "Cf_gregorian: chronological Julian day too old."; of_mjd ?wday ?yday (day - 2400001) let to_mjd = let times365 = [| 0; 365; 730; 1095 |] in let times36524 = [| 0; 36524; 73048; 109572 |] in let montab = [| 0; 31; 61; 92; 122; 153; 184; 214; 245; 275; 306; 337 |] in let adjday y d = y mod 400, d + (146097 * (y / 400)) in fun ~year:y ~month:m ~day:d -> let d = d - 678882 and m = pred m in let y, d = adjday y d in let y, m = if m >= 2 then y, m - 2 else pred y, m + 10 in let y = y + (m / 12) and m = m mod 12 in let y, m = if m < 0 then pred y, m + 12 else y, m in let y, d = adjday y (d + (Array.unsafe_get montab m)) in let y, d = if y < 0 then y + 400, d - 146097 else y, d in let d = d + (Array.unsafe_get times365 (y land 3)) and y = y lsr 2 in let d = d + 1461 * (y mod 25) and y = y / 25 in d + (Array.unsafe_get times36524 (y land 3)) let to_cjd_unsafe ~year ~month ~day = let d = to_mjd ~year ~month ~day in d + 2400001 let minyear_, minmonth_, minday_ = of_cjd (min_int + 2400001) let maxyear_, maxmonth_, maxday_ = of_cjd max_int let is_leap_year_ y = y mod 4 = 0 && y mod 100 <> 0 || y mod 400 = 0 let md_nonleap_ = [| 31; 28; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |] let md_leap_ = [| 31; 29; 31; 30; 31; 30; 31; 31; 30; 31; 30; 31 |] let is_valid ~year:y ~month:m ~day:d = m >= 1 && m <= 12 && d >= 1 && d <= 31 && begin let md = if is_leap_year_ y then md_leap_ else md_nonleap_ in d <= Array.unsafe_get md (pred m) && y >= minyear_ && y <= maxyear_ && not (y = minyear_ && (m < minmonth_ || m = minmonth_ && d < minday_)) && not (y = maxyear_ && (m > maxmonth_ || m = maxmonth_ && d > maxday_)) end let to_cjd ~year:y ~month:m ~day:d = if m < 1 || m > 12 then invalid_arg "Cf_gregorian.to_mjd: month 1..12"; if d < 1 || d > 31 then invalid_arg "Cf_gregorian.to_mjd: day 1..31"; let md = if is_leap_year_ y then md_leap_ else md_nonleap_ in if d > Array.unsafe_get md (pred m) then invalid_arg "Cf_gregorian.to_mjd: date not gregorian"; if y < minyear_ || y > maxyear_ || (y = minyear_ && (m < minmonth_ || m = minmonth_ && d < minday_)) || (y = maxyear_ && (m > maxmonth_ || m = maxmonth_ && d > maxday_)) then invalid_arg "Cf_gregorian.to_mjd: integer overflow"; to_cjd_unsafe ~year:y ~month:m ~day:d (*--- End of File [ cf_gregorian.ml ] ---*) cf-0.10/cf_gregorian.mli0000644000175000017500000001101610433520572015046 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_gregorian.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** Conversions between the Gregorian calendar and Chronological Julian Day. *) (** {6 Overview} *) (** This module implements functions for converting dates in the Gregorian calendar to and from a Chronological Julian Day (CJD) number. CJD numbers are signed integers, and day zero began at 00:00:00 TAI, 24 Nov -4713 CE. Gregorian dates between 12 Aug -2937947 CE and 27 Feb 2935093 inclusive are convertible to Chronological Julian Day numbers on platforms where the Ocaml integer is a 31-bit integer. Days of the month are represented by integers from 1 to 31. Months of the year are represented by integers from 1 to 12. Days of the week are represented by integers from 0 to 6, where 0 is Sunday and 6 is Saturday. Days of the year are numbered from 0 to 365, where only leap years contain a day numbered 365. *) (** {6 Functions} *) (** [is_valid ~year ~month ~day] returns [true] if [year], [month] and [day] arguments specify a valid Gregorian date. *) val is_valid: year:int -> month:int -> day:int -> bool (** [of_cjd ?wday ?yday cjd] returns a 3-tuple [(year, month, day)] with the year, month and day of the corresponding Gregorian date represented in integer form. If the [?wday] parameter is used, then the day of the week is computed and stored. If the [?yday] parameter is used, then the day of the year is computed and stored. Raises [Invalid_argument] if [cjd] is in the very small range of values in the ancient past where the conversion algorithm would otherwise result in date in the extreme future. *) val of_cjd: ?wday:(int ref) -> ?yday:(int ref) -> int -> int * int * int (** [to_cjd ~year ~month ~day] returns the Chronological Julian Day number of the specified Gregorian date. Raise [Invalid_argument] if [year], [month] or [day] indicates an invalid Gregorian date, or the calculation would overflow the integer representation of CJD numbers. *) val to_cjd: year:int -> month:int -> day:int -> int (** [to_cjd_unsafe ~year ~month ~day] is the same as [to_cjd ~year ~month ~day], except the parameters are not checked for boundaries and that the date is a valid Gregorian date. Use this version if the date is already known to be valid, and in the range of representable CJD numbers. *) val to_cjd_unsafe: year:int -> month:int -> day:int -> int (**/**) (** The [of_mjd] function computes the Gregorian date from a Modified Julian Day number (which is a deprecated variant of the Julian Day reckoning that uses a different starting epoch). It is used by the functions in the {!Cf_stdtime} module for conversions to TAI. *) val of_mjd: ?wday:(int ref) -> ?yday:(int ref) -> int -> int * int * int (** The [to_mjd] function computes the Modified Julian Day number corresponding to a Gregorian calendar date. It is used by the functions in the {!Cf_stdtime} module for conversions to TAI. *) val to_mjd: year:int -> month:int -> day:int -> int (*--- End of File [ cf_gregorian.mli ] ---*) cf-0.10/cf_heap.ml0000644000175000017500000000437010433520572013642 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_heap.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) module type T = sig type t module Element: sig type t end val nil: t val empty: t -> bool val size: t -> int val head: t -> Element.t val tail: t -> t val pop: t -> (Element.t * t) option val put: Element.t -> t -> t val merge: t -> t -> t val iterate: (Element.t -> unit) -> t -> unit val predicate: (Element.t -> bool) -> t -> bool val fold: ('b -> Element.t -> 'b) -> 'b -> t -> 'b val filter: (Element.t -> bool) -> t -> t val partition: (Element.t -> bool) -> t -> t * t val of_seq: Element.t Cf_seq.t -> t val of_list: Element.t list -> t val to_seq: t -> Element.t Cf_seq.t val to_seq2: t -> (Element.t * t) Cf_seq.t end (*--- End of File [ cf_heap.ml ] ---*) cf-0.10/cf_heap.mli0000644000175000017500000001305410433520572014012 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_heap.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** A module type for functional heap implementations. *) (** {6 Module Type} *) (** This module defines the common interface to functional heaps in the {!Cf} library. *) module type T = sig (** The heap type *) type t (** A module defining the type of the element. Some heap implementations may define more functions in this module for disambiguating elements from one another. *) module Element: sig type t end (** The empty heap. *) val nil: t (** Use [empty h] to test whether the heap [h] is empty. *) val empty: t -> bool (** Use [size h] to count the number of elements in the heap [h]. Runs in O(n) time and O(log N) space. *) val size: t -> int (** Use [head h] to obtain the element on the top of the heap [h]. Raises [Not_found] if the heap is empty. *) val head: t -> Element.t (** Use [tail h] to obtain the heap produced by discarding the element on the top of heap [h]. If [h] is the empty heap, then the empty heap is returned. *) val tail: t -> t (** Use [pop h] to obtain the head and the tail of a heap [h] in one operation. Returns [None] if the [h] is empty. *) val pop: t -> (Element.t * t) option (** Use [put e h] to obtain a new heap that is the result of inserting the element [e] into the heap [h]. *) val put: Element.t -> t -> t (** Use [merge h1 h2] to obtain a new heap that is the result of merging all the elements of [h1] and [h2] into a single heap. *) val merge: t -> t -> t (** Use [iterate f h] to apply [f] to every element in the heap [h] in an arbitrary order (not top to bottom). Runs in O(n) time and O(1) space. *) val iterate: (Element.t -> unit) -> t -> unit (** Use [predicate f h] to test whether all the elements in heap [h] satisfy the predicate function [f]. Runs in O(n) time (with a short cut when an element is found to fail the predicate) and O(1) space. Visits the elements in the heap in arbitrary order (not top to bottom). *) val predicate: (Element.t -> bool) -> t -> bool (** Use [fold f s h] to produce the result of folding a value [s] into the elements of heap [h] with the folding function [f] in an arbitrary order (not top to bottom). Runs in O(n) time and O(1) space. *) val fold: ('b -> Element.t -> 'b) -> 'b -> t -> 'b (** Use [filter f h] to apply [f] to each element in the heap [h] in an arbitrary order (not to top bottom), and produce a new heap that contains only those elements for which [f pair] returned [true]. *) val filter: (Element.t -> bool) -> t -> t (** Use [partition f h] to obtain a pair of new heaps that are the result of applying the partitioning function [f] to each element in the heap [h] in an arbitrary order (not top to bottom). The first heap returned will contain all the elements for which [f pair] returned true, and the second heap will return all the remaining elements. *) val partition: (Element.t -> bool) -> t -> t * t (** Use [of_seq z] to construct a heap from a sequence of elements. Evaluates the whole sequence. Runs in O(n) time and O(1) space. *) val of_seq: Element.t Cf_seq.t -> t (** Use [of_list s] to construct a heap from a list of elements. Runs in O(n) time and O(1) space. *) val of_list: Element.t list -> t (** Use [to_seq h] to produce a sequence of elements in top to bottom order from the heap [h]. *) val to_seq: t -> Element.t Cf_seq.t (** Use [to_seq2 h] to produce a sequence of elements from the heap [h] where the first element of each pair is a key-value pair obtained from the head of the heap, and the second element of the pair is the corresponding tail of the heap. *) val to_seq2: t -> (Element.t * t) Cf_seq.t end (*--- End of File [ cf_heap.mli ] ---*) cf-0.10/cf_ip4_addr.ml0000644000175000017500000001151710454115143014411 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_ip4_addr.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) external init_: unit -> unit = "cf_ip4_addr_init";; init_ ();; type -'a t type opaque = [ `AF_INET ] type category = Unspecified | Unicast | Multicast | Experimental | Broadcast type unspecified = [ opaque | `X ] type unicast = [ opaque | `U ] type multicast = [ opaque | `M ] type experimental = [ opaque | `E ] type broadcast = [ opaque | `B ] external category: opaque t -> category = "cf_ip4_addr_category" external is_unicast: [> opaque ] t -> unicast t = "cf_ip4_addr_is_unicast" external is_multicast: [> opaque ] t -> multicast t = "cf_ip4_addr_is_multicast" external is_experimental: [> opaque ] t -> experimental t = "cf_ip4_addr_is_experimental" type unicast_realm = U_loopback | U_link | U_private | U_global external unicast_realm: [> unicast ] t -> unicast_realm = "cf_ip4_addr_unicast_realm" type multicast_realm = M_link | M_global external multicast_realm: [> multicast ] t -> multicast_realm = "cf_ip4_addr_multicast_realm" external any_: unit -> unspecified t = "cf_ip4_addr_any" external broadcast_: unit -> broadcast t = "cf_ip4_addr_broadcast" external loopback_: unit -> unicast t = "cf_ip4_addr_loopback" external empty_group_: unit -> multicast t = "cf_ip4_addr_empty_group" external all_hosts_group_: unit -> multicast t = "cf_ip4_addr_all_hosts_group" external all_routers_group_: unit -> multicast t = "cf_ip4_addr_all_routers_group" let any = any_ () let broadcast = broadcast_ () let loopback = loopback_ () let empty_group = empty_group_ () let all_hosts_group = all_hosts_group_ () let all_routers_group = all_routers_group_ () external equal: ([> opaque ] t as 'a) -> 'a -> bool = "cf_ip4_addr_equal" external compare: ([> opaque ] t as 'a) -> 'a -> int = "cf_ip4_addr_compare_aux" external pton: string -> opaque t option = "cf_inet_pton4" external ntop: [> opaque ] t -> string = "cf_inet_ntop4" external network_min_prefix_: ([> opaque ] as 'a) t -> int = "cf_ip4_addr_network_min_prefix" external network_member_: ([> opaque ] as 'a) t -> int -> 'a t -> bool = "cf_ip4_addr_network_member" external network_limit_: ([> opaque ] as 'a) t -> int -> int -> 'a t = "cf_ip4_addr_network_limit" external network_next_: 'a t -> int -> 'a t = "cf_ip4_addr_network_next" external network_netmask_: int -> string = "cf_ip4_addr_network_netmask" let rec iterator_ ~dir ~lim addr = lazy begin if equal addr lim then Cf_seq.Z else Cf_seq.P (addr, iterator_ ~dir ~lim (network_next_ addr dir)) end type 'a network = { net_prefix_: int; net_minimum_: 'a t; net_maximum_: 'a t; net_member_: 'a t -> bool; } constraint 'a = [> opaque ] let net_create ?subnet:s n = let p = match s with Some p -> p | None -> network_min_prefix_ n in { net_prefix_ = p; net_minimum_ = network_limit_ n p (-1); net_maximum_ = network_limit_ n p 1; net_member_ = fun x -> network_member_ n p x; } let net_number net = net.net_minimum_ let net_broadcast net = net.net_maximum_ let net_prefix net = net.net_prefix_ let net_member net = net.net_member_ let net_mask net = network_netmask_ net.net_prefix_ let net_increasing net = iterator_ ~dir:1 ~lim:net.net_maximum_ net.net_minimum_ let net_decreasing net = iterator_ ~dir:(-1) ~lim:net.net_minimum_ net.net_maximum_ (*--- End of File [ cf_ip4_addr.ml ] ---*) cf-0.10/cf_ip4_addr.mli0000644000175000017500000001574610454115143014572 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_ip4_addr.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** IPv4 addresses with attribute parameters for type safety. This module implements IPv4 addresses in an abstract type suitable for use with the {!Cf_nameinfo} module, the {!Cf_socket} module and its cognates for IPv4 transports. Internally, the IPv4 address is represented as a boxed 4-byte custom block. Externally, the IPv4 address abstract type is parameterized with a shadow attribute that constrains how it may be used depending on its address category. *) (** The type of IPv4 addresses, parameterized by address category attribute. *) type -'a t (** The shadow attribute type of IPv4 addresses of unknown category. *) type opaque = [ `AF_INET ] (** The IPv4 address category type. *) type category = | Unspecified (** 0.0.0.0 *) | Unicast (** 0.0.0.1 to 223.255.255.255 *) | Multicast (** 224.0.0.0 to 239.255.255.255 *) | Experimental (** 240.0.0.0 to 255.255.255.254 *) | Broadcast (** 255.255.255.255 *) (** The shadow attribute type of IPv4 addresses of the Unspecified category. *) type unspecified = [ opaque | `X ] (** The shadow attribute type of IPv4 addresses of the Unicast category. *) type unicast = [ opaque | `U ] (** The shadow attribute type of IPv4 addresses of the Multicast category. *) type multicast = [ opaque | `M ] (** The shadow attribute type of IPv4 addresses of the Experimental category. *) type experimental = [ opaque | `E ] (** The shadow attribute type of IPv4 addresses of the Broadcast category. *) type broadcast = [ opaque | `B ] (** Use [category a] to obtain the category of an opaque IPv4 address. *) val category: opaque t -> category (** Use [is_unicast a] to validate that an IPv4 address is a unicast address. Raises [Failure] if the address is not a unicast address. *) val is_unicast: [> opaque ] t -> unicast t (** Use [is_multicast a] to validate that an IPv4 address is a multicast address. Raises [Failure] if the address is not a multicast address. *) val is_multicast: [> opaque ] t -> multicast t (** Use [is_experimental a] to validate that an IPv4 address is an experimental address. Raises [Failure] if the address is not an experimental address. *) val is_experimental: [> opaque ] t -> experimental t (** The type of unicast address realms. *) type unicast_realm = | U_loopback (** Loopback, i.e. 127/8 *) | U_link (** Link-local, i.e. 169.254/16 *) | U_private (** Private, i.e. 10/8, 172.16/12 and 192.168/16 *) | U_global (** Global, all other unicast addresses *) (** Use [unicast_realm a] to identify the address realm of the unicast address [a]. *) val unicast_realm: [> unicast ] t -> unicast_realm (** The type of multicast address realms. *) type multicast_realm = M_link | M_global (** Use [multicast realm a] to identify the address of the multicast address [a]. *) val multicast_realm: [> multicast ] t -> multicast_realm (** The unspecified IPv4 address, i.e. 0.0.0.0. *) val any: unspecified t (** The link-local broadcast IPv4 address, i.e. 255.255.255.255. *) val broadcast: broadcast t (** The default loopback host address, i.e. 127.0.0.1. *) val loopback: unicast t (** The empty group multicast address, i.e. 224.0.0.0. *) val empty_group: multicast t (** The all-hosts group multicast address, i.e. 224.0.0.1 *) val all_hosts_group: multicast t (** The all-routers group multicast address, i.e. 224.0.0.2 *) val all_routers_group: multicast t (** Use [equal a1 a2] to compare two IPv4 addresses for equality. *) val equal: [> opaque ] t -> [> opaque ] t -> bool (** Use [compare a1 a2] to compare the ordinality of two IPv4 addresses. *) val compare: [> opaque ] t -> [> opaque ] t -> int (** Use [pton s] to convert the string [s] containing an IPv4 address in dot-quad format to its equivalent opaque IPv4 address. Returns [None] if the string is not in dot-quad format. *) val pton: string -> opaque t option (** Use [ntop a] to obtain a string representation of the IPv4 address [a] in dot-quad format. *) val ntop: [> opaque ] t -> string (** The type of an IPv4 network identifier. *) type 'a network constraint 'a = [> opaque ] (** Use [net_create ?subnet a] to create an IPv4 network identifier that contains the address [a] in its logical scope, optional constraining the network to subnetwork of width [subnet]. *) val net_create: ?subnet:int -> ([> opaque ] as 'a) t -> 'a network (** Use [net_number n] to produce the IPv4 address conventionally used to identify the network. *) val net_number: 'a network -> 'a t (** Use [net_broadcast n] to produce the IPv4 address conventionally used to identify the broadcast address for the network or subnet. *) val net_broadcast: 'a network -> 'a t (** Use [net_prefix] to obtain the number of bits in the subnet mask. *) val net_prefix: 'a network -> int (** Use [net_member n a] to test whether the address [a] is in the scope of the network [n]. *) val net_member: 'a network -> 'a t -> bool (** Use [net_mask n] to return a string representation of the subnet mask for the network [n] in traditional dot-quad format. *) val net_mask: 'a network -> string (** Use [net_increasing n] to obtain the sequence of unicast IPv4 addresses belong to the network [n] in increasing order. *) val net_increasing: 'a network -> 'a t Cf_seq.t (** Use [net_decreasing n] to obtain the sequence of unicast IPv4 addresses belong to the network [n] in decreasing order. *) val net_decreasing: 'a network -> 'a t Cf_seq.t (*--- End of File [ cf_ip4_addr.mli ] ---*) cf-0.10/cf_ip4_addr_p.c0000644000175000017500000003664610454115143014554 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_ip4_addr_p.c Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_ip4_addr_p.h" #include #include #include #define FAILWITH(S) (failwith("Cf_ip4_addr." S)) /*---------------------------------------------------------------------------* IPv4 addresses *---------------------------------------------------------------------------*/ enum cf_ip4_addr_unicast_realm { Cf_ip4_addr_U_loopback, Cf_ip4_addr_U_link, Cf_ip4_addr_U_private, Cf_ip4_addr_U_global }; enum cf_ip4_addr_multicast_realm { Cf_ip4_addr_M_link, Cf_ip4_addr_M_global }; static int cf_ip4_addr_compare(value v1, value v2) { CAMLparam2(v1, v2); const u_int8_t* addr1Ptr; const u_int8_t* addr2Ptr; int i, result; addr1Ptr = (u_int8_t*)(&Cf_ip4_addr_val(v1)->s_addr) + 3; addr2Ptr = (u_int8_t*)(&Cf_ip4_addr_val(v2)->s_addr) + 3; for (i = 4; i >= 0; --i, --addr1Ptr, --addr2Ptr) { result = *addr1Ptr - *addr2Ptr; if (result) break; } CAMLreturn(result); } static long cf_ip4_addr_hash(value v) { CAMLparam1(v); long result; result = (long) ntohl(Cf_ip4_addr_val(v)->s_addr); CAMLreturn(result); } static void cf_ip4_addr_serialize (value v, unsigned long* size32Ptr, unsigned long* size64Ptr) { CAMLparam1(v); serialize_block_1(&Cf_ip4_addr_val(v)->s_addr, 4); *size32Ptr = 4; *size64Ptr = 4; CAMLreturn0; } static unsigned long cf_ip4_addr_deserialize(void* bufferPtr) { deserialize_block_1(bufferPtr, 4); return 4; } static struct custom_operations cf_ip4_addr_op = { "org.conjury.ocnae.cf.in_addr", custom_finalize_default, cf_ip4_addr_compare, cf_ip4_addr_hash, cf_ip4_addr_serialize, cf_ip4_addr_deserialize }; value cf_ip4_addr_alloc(const struct in_addr* addrPtr) { value result; result = alloc_custom(&cf_ip4_addr_op, 4, 0, 1); *Cf_ip4_addr_val(result) = *addrPtr; return result; } int cf_ip4_addr_category_code(const struct in_addr* addrPtr) { u_int32_t addrN = ntohl(addrPtr->s_addr); if (!addrN) return Cf_ip4_addr_unspecified; else if (!~addrN) return Cf_ip4_addr_broadcast; else if (IN_CLASSD(addrN)) return Cf_ip4_addr_multicast; else if (IN_EXPERIMENTAL(addrN)) return Cf_ip4_addr_experimental; return Cf_ip4_addr_unicast; } /*--- external category: opaque t -> category = "cf_ip4_addr_category" ---*/ CAMLprim value cf_ip4_addr_category(value addr) { CAMLparam1(addr); u_int32_t n = cf_ip4_addr_category_code(Cf_ip4_addr_val(addr)); CAMLreturn(Val_int(n)); } /*--- external is_unicast: [> opaque ] t -> unicast t = "cf_ip4_addr_is_unicast" ---*/ CAMLprim value cf_ip4_addr_is_unicast(value addr) { CAMLparam1(addr); u_int32_t addrN; addrN = Cf_ip4_addr_val(addr)->s_addr; addrN = ntohl(addrN); if (!(addrN && (IN_CLASSA(addrN) || IN_CLASSB(addrN) || IN_CLASSC(addrN)))) FAILWITH("is_unicast"); CAMLreturn(addr); } /*--- external is_multicast: [> opaque ] t -> multicast t = "cf_ip4_addr_is_multicast" ---*/ CAMLprim value cf_ip4_addr_is_multicast(value addr) { CAMLparam1(addr); u_int32_t addrN; addrN = Cf_ip4_addr_val(addr)->s_addr; addrN = ntohl(addrN); if (!IN_CLASSD(addrN)) FAILWITH("is_multicast"); CAMLreturn(addr); } /*--- external is_experimental: [> opaque ] t -> experimental t = "cf_ip4_addr_is_experimental" ---*/ CAMLprim value cf_ip4_addr_is_experimental(value addr) { CAMLparam1(addr); u_int32_t addrN; addrN = Cf_ip4_addr_val(addr)->s_addr; addrN = ntohl(addrN); if (!IN_EXPERIMENTAL(addrN)) FAILWITH("is_experimental"); CAMLreturn(addr); } #ifndef IN_LINKLOCAL #define IN_LINKLOCALNETNUM (u_int32_t)0xA9FE0000 /* 169.254.0.0 */ #define IN_LINKLOCAL(i) \ (((u_int32_t)(i) & IN_CLASSB_NET) == IN_LINKLOCALNETNUM) #endif /*--- external unicast_realm: [> unicast ] t -> unicast_realm = "cf_ip4_addr_unicast_realm" ---*/ CAMLprim value cf_ip4_addr_unicast_realm(value addr) { CAMLparam1(addr); static const u_int32_t rfc1918_net[][2] = { { 0x0A000000, 0xFF000000 }, /* 10/8 */ { 0xAC100000, 0xFFF00000 }, /* 172.16/12 */ { 0xC0A80000, 0xFFFF0000 } /* 192.168/16 */ }; u_int32_t addrN; value result; addrN = Cf_ip4_addr_val(addr)->s_addr; addrN = ntohl(addrN); if ((addrN & IN_CLASSA_NET) == (IN_LOOPBACKNET << IN_CLASSA_NSHIFT)) result = Val_int(Cf_ip4_addr_U_loopback); else if (IN_LINKLOCAL(addrN)) result = Val_int(Cf_ip4_addr_U_link); else { int i; result = Val_int(Cf_ip4_addr_U_global); for (i = 0; i < 3; ++i) if ((addrN & rfc1918_net[i][1]) == rfc1918_net[i][0]) { result = Val_int(Cf_ip4_addr_U_private); break; } } CAMLreturn(result); } /*--- external multicast_realm: [> multicast ] t -> multicast_realm = "cf_ip4_addr_multicast_realm" ---*/ CAMLprim value cf_ip4_addr_multicast_realm(value addr) { CAMLparam1(addr); u_int32_t addrN; addrN = Cf_ip4_addr_val(addr)->s_addr; addrN = ntohl(addrN); CAMLreturn(Val_int((addrN <= INADDR_MAX_LOCAL_GROUP) ? Cf_ip4_addr_M_link : Cf_ip4_addr_M_global)); } static value cf_ip4_addr_any_val = Val_unit; static value cf_ip4_addr_loopback_val = Val_unit; static value cf_ip4_addr_broadcast_val = Val_unit; static value cf_ip4_addr_empty_group_val = Val_unit; static value cf_ip4_addr_all_hosts_group_val = Val_unit; static value cf_ip4_addr_all_routers_group_val = Val_unit; /*--- external any_: unit -> unspecified t = "cf_ip4_addr_any" ---*/ CAMLprim value cf_ip4_addr_any(value unit) { CAMLparam0(); CAMLreturn(cf_ip4_addr_any_val); } /*--- external broadcast_: unit -> broadcast t = "cf_ip4_addr_broadcast" ---*/ CAMLprim value cf_ip4_addr_loopback(value unit) { CAMLparam0(); CAMLreturn(cf_ip4_addr_loopback_val); } /*--- external loopback_: unit -> unicast t = "cf_ip4_addr_loopback" ---*/ CAMLprim value cf_ip4_addr_broadcast(value unit) { CAMLparam0(); CAMLreturn(cf_ip4_addr_broadcast_val); } /*--- external empty_group_: unit -> multicast t = "cf_ip4_addr_empty_group" ---*/ CAMLprim value cf_ip4_addr_empty_group(value unit) { CAMLparam0(); CAMLreturn(cf_ip4_addr_empty_group_val); } /*--- external all_hosts_group_: unit -> multicast t = "cf_ip4_addr_all_hosts_group" ---*/ CAMLprim value cf_ip4_addr_all_hosts_group(value unit) { CAMLparam0(); CAMLreturn(cf_ip4_addr_all_hosts_group_val); } /*--- external all_routers_group_: unit -> multicast t = "cf_ip4_addr_all_routers_group" ---*/ CAMLprim value cf_ip4_addr_all_routers_group(value unit) { CAMLparam0(); CAMLreturn(cf_ip4_addr_all_routers_group_val); } /*--- external equal: ([> opaque ] t as 'a) -> 'a -> bool = "cf_ip4_addr_equal" ---*/ CAMLprim value cf_ip4_addr_equal(value addr1, value addr2) { CAMLparam2(addr1, addr2); value result; if (Cf_ip4_addr_val(addr1)->s_addr == Cf_ip4_addr_val(addr2)->s_addr) result = Val_true; else result = Val_false; CAMLreturn(result); } /*--- external compare: [> opaque ] t -> [> opaque ] t -> int = "cf_ip4_addr_compare_aux" ---*/ CAMLprim value cf_ip4_addr_compare_aux(value v1, value v2) { int d = cf_ip4_addr_compare(v1, v2); return Val_int(d); } /*--- external pton: string -> opaque t = "cf_inet_pton4" ---*/ CAMLprim value cf_inet_pton4(value str) { CAMLparam1(str); CAMLlocal1(resultVal); struct in_addr addr; int result; result = inet_pton(AF_INET, String_val(str), &addr); if (result < 0) failwith("inet_pton(AF_INET, ...)"); resultVal = Val_int(0); if (result > 0) { resultVal = alloc_small(1, 0); Store_field(resultVal, 0, cf_ip4_addr_alloc(&addr)); } CAMLreturn(resultVal); } /*--- external ntop: [> opaque ] t -> string = "cf_inet_ntop4" ---*/ CAMLprim value cf_inet_ntop4(value addrVal) { CAMLparam1(addrVal); CAMLlocal1(result); struct in_addr* addrPtr; char buffer[INET_ADDRSTRLEN]; if (!inet_ntop(AF_INET, Cf_ip4_addr_val(addrVal), buffer, sizeof buffer)) failwith("inet_ntop(AF_INET, ....)"); CAMLreturn(copy_string(buffer)); } static int cf_ip4_addr_network_min_prefix_compute (const struct in_addr* addrPtr) { u_int32_t network; int prefixLen; network = addrPtr->s_addr; network = ntohl(network); if (IN_CLASSA(network)) prefixLen = 8; else if (IN_CLASSB(network)) prefixLen = 16; else if (IN_CLASSC(network)) prefixLen = 24; else prefixLen = 4; return prefixLen; } static u_int32_t cf_ip4_addr_compute_hostmask(unsigned int prefixLen) { u_int32_t hostMask; hostMask = ((1 << (32 - prefixLen)) - 1); return htonl(hostMask); } static void cf_ip4_addr_compute_limits (const struct in_addr* addrPtr, unsigned int prefixLen, struct in_addr* minPtr, struct in_addr* maxPtr) { u_int32_t hostMask; hostMask = cf_ip4_addr_compute_hostmask(prefixLen); if (minPtr) minPtr->s_addr = addrPtr->s_addr & ~hostMask; if (maxPtr) maxPtr->s_addr = addrPtr->s_addr | ~hostMask; } /*--- external network_min_prefix_: ([> opaque ] as 'a) t -> int = "cf_ip4_addr_network_min_prefix" ---*/ CAMLprim value cf_ip4_addr_network_min_prefix(value addr) { CAMLparam1(addr); int result; result = cf_ip4_addr_network_min_prefix_compute(Cf_ip4_addr_val(addr)); CAMLreturn(Val_int(result)); } /*--- external network_member_: n:([> opaque ] as 'a) t -> p:int -> 'a t -> bool = "cf_ip4_addr_network_member" ---*/ CAMLprim value cf_ip4_addr_network_member (value networkVal, value prefixLenVal, value addrVal) { CAMLparam3(networkVal, prefixLenVal, addrVal); int prefixLen, result; struct in_addr* networkPtr; struct in_addr* addrPtr; struct in_addr min, max; u_int32_t mask; prefixLen = Int_val(prefixLenVal); if (prefixLen < 1 || prefixLen > 31) FAILWITH("network: prefix length"); networkPtr = Cf_ip4_addr_val(networkVal); addrPtr = Cf_ip4_addr_val(addrVal); cf_ip4_addr_compute_limits (networkPtr, (unsigned int) prefixLen, &min, &max); mask = ~(min.s_addr ^ max.s_addr); result = !!((networkPtr->s_addr & mask) == (addrPtr->s_addr & mask)); CAMLreturn(result ? Val_true : Val_false); } /*--- external network_limit_: n:([> opaque ] as 'a) t -> p:int -> int -> 'a t = "cf_ip4_addr_network_limit" ---*/ CAMLprim value cf_ip4_addr_network_limit (value networkVal, value prefixLenVal, value dirVal, value addrVal) { CAMLparam4(networkVal, prefixLenVal, dirVal, addrVal); int prefixLen, dir; struct in_addr* networkPtr; struct in_addr* addrPtr; struct in_addr* minPtr; struct in_addr* maxPtr; struct in_addr limit; networkPtr = Cf_ip4_addr_val(networkVal); prefixLen = Int_val(prefixLenVal); if (prefixLen >= 4 && prefixLen < 32) { u_int32_t network; network = networkPtr->s_addr; network = ntohl(network); if ( (prefixLen < 24 && IN_CLASSC(network)) || (prefixLen < 16 && IN_CLASSB(network)) || (prefixLen < 8 && IN_CLASSA(network)) || (prefixLen < 4 /* allowed for both class D and class E */) ) FAILWITH("network: invalid prefix length for address class"); } else FAILWITH("network: invalid prefix length"); addrPtr = Cf_ip4_addr_val(addrVal); dir = Int_val(dirVal); minPtr = (dir < 0) ? &limit : 0; maxPtr = (dir > 0) ? &limit : 0; limit.s_addr = 0; cf_ip4_addr_compute_limits (networkPtr, (unsigned int) prefixLen, minPtr, maxPtr); CAMLreturn (cf_ip4_addr_alloc(&limit)); } /*--- external network_next_: 'a t -> int -> 'a t = "cf_ip4_addr_network_next" ---*/ CAMLprim value cf_ip4_addr_network_next(value addrVal, value stepVal) { CAMLparam2(addrVal, stepVal); struct in_addr result; u_int32_t x; x = Cf_ip4_addr_val(addrVal)->s_addr; x = ntohl(x); x += Val_int(stepVal); result.s_addr = htonl(x); CAMLreturn (cf_ip4_addr_alloc(&result)); } /*--- external network_netmask_: int -> string = "cf_ip4_addr_network_netmask" ---*/ CAMLprim value cf_ip4_addr_network_netmask(value prefixLen) { CAMLparam1(prefixLen); struct in_addr addr; char buffer[INET_ADDRSTRLEN]; addr.s_addr = ~cf_ip4_addr_compute_hostmask(Int_val(prefixLen)); if (inet_ntop(AF_INET, &addr, buffer, sizeof buffer) == 0) failwith("inet_ntop(AF_INET, ....)"); CAMLreturn(copy_string(buffer)); } /*--- Initialization primitive ---*/ CAMLprim value cf_ip4_addr_init(value unit) { struct in_addr addr; register_custom_operations(&cf_ip4_addr_op); addr.s_addr = htonl(INADDR_ANY); register_global_root(&cf_ip4_addr_any_val); cf_ip4_addr_any_val = cf_ip4_addr_alloc(&addr); addr.s_addr = htonl(INADDR_LOOPBACK); register_global_root(&cf_ip4_addr_loopback_val); cf_ip4_addr_loopback_val = cf_ip4_addr_alloc(&addr); addr.s_addr = htonl(INADDR_BROADCAST); register_global_root(&cf_ip4_addr_broadcast_val); cf_ip4_addr_broadcast_val = cf_ip4_addr_alloc(&addr); addr.s_addr = htonl(INADDR_UNSPEC_GROUP); register_global_root(&cf_ip4_addr_empty_group_val); cf_ip4_addr_empty_group_val = cf_ip4_addr_alloc(&addr); addr.s_addr = htonl(INADDR_ALLHOSTS_GROUP); register_global_root(&cf_ip4_addr_all_hosts_group_val); cf_ip4_addr_all_hosts_group_val = cf_ip4_addr_alloc(&addr); addr.s_addr = htonl(INADDR_ALLRTRS_GROUP); register_global_root(&cf_ip4_addr_all_routers_group_val); cf_ip4_addr_all_routers_group_val = cf_ip4_addr_alloc(&addr); return Val_unit; } /*--- End of File [ cf_ip4_addr_p.c ] ---*/ cf-0.10/cf_ip4_addr_p.h0000644000175000017500000000411410404616701014543 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_ip4_addr_p.h Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_IP4_ADDR_P_H #define _CF_IP4_ADDR_P_H #include "cf_common_p.h" #include #include #define Cf_ip4_addr_val(v) ((struct in_addr*) Data_custom_val(v)) extern value cf_ip4_addr_alloc(const struct in_addr* addrPtr); extern int cf_ip4_addr_category_code(const struct in_addr* addrPtr); enum cf_ip4_addr_category { Cf_ip4_addr_unspecified, Cf_ip4_addr_unicast, Cf_ip4_addr_multicast, Cf_ip4_addr_experimental, Cf_ip4_addr_broadcast }; #endif /* defined(_CF_IP4_ADDR_P_H) */ /*--- End of File [ cf_ip4_addr_p.h ] ---*/ cf-0.10/cf_ip4_proto.ml0000644000175000017500000000635410433520572014650 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_ip4_proto.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) external init_: unit -> unit = "cf_ip4_proto_init";; init_ ();; external domain_: unit -> 'a Cf_socket.domain = "cf_ip4_proto_domain" module AF = struct type tag = [ `AF_INET ] type address = Cf_ip4_addr.opaque Cf_ip4_addr.t * int let domain = domain_ () external to_sockaddr: address -> tag Cf_socket.sockaddr = "cf_ip4_proto_to_sockaddr" external of_sockaddr: tag Cf_socket.sockaddr -> address = "cf_ip4_proto_of_sockaddr" let unspecified = to_sockaddr ((Cf_ip4_addr.any :> Cf_ip4_addr.opaque Cf_ip4_addr.t), 0) end module TCP = struct module AF = AF module ST = Cf_socket.SOCK_STREAM let protocol = Cf_ip_common.zero end module UDP = struct module AF = AF module ST = Cf_socket.SOCK_DGRAM let protocol = Cf_ip_common.zero end type mreq = { imr_multiaddr: Cf_ip4_addr.multicast Cf_ip4_addr.t; imr_interface: Cf_ip4_addr.unicast Cf_ip4_addr.t; } type sockopt_index = IP_TTL | IP_ADD_MEMBERSHIP | IP_DROP_MEMBERSHIP | IP_MULTICAST_IF | IP_MULTICAST_TTL | IP_MULTICAST_LOOP external sockopt_lift: sockopt_index -> ('v,[`AF_INET],'st) Cf_socket.sockopt = "cf_ip4_proto_sockopt_lift" let ip_ttl = Obj.magic (sockopt_lift IP_TTL) let ip_add_membership = Obj.magic (sockopt_lift IP_ADD_MEMBERSHIP) let ip_drop_membership = Obj.magic (sockopt_lift IP_DROP_MEMBERSHIP) let ip_multicast_if = Obj.magic (sockopt_lift IP_MULTICAST_IF) let ip_multicast_ttl = Obj.magic (sockopt_lift IP_MULTICAST_TTL) let ip_multicast_loop = Obj.magic (sockopt_lift IP_MULTICAST_LOOP) external siocgifaddr: ([ `AF_INET ], 'st) Cf_socket.t -> string -> [> Cf_ip4_addr.unicast ] Cf_ip4_addr.t = "cf_ip4_proto_siocgifaddr" (*--- End of File [ cf_ip4_proto.ml ] ---*) cf-0.10/cf_ip4_proto.mli0000644000175000017500000000710510433520572015014 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_ip4_proto.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** The [AF_INET] address family (for use with TCP and UDP over IPv4). *) (** {6 Modules and Types} *) (** The address family module for IPv4 transports. *) module AF: Cf_socket.AF with type tag = [ `AF_INET ] and type address = Cf_ip4_addr.opaque Cf_ip4_addr.t * int (** The TCP (IPv4) socket protocol. *) module TCP: Cf_socket.P with module AF = AF and module ST = Cf_socket.SOCK_STREAM (** The UDP (IPv4) socket protocol. *) module UDP: Cf_socket.P with module AF = AF and module ST = Cf_socket.SOCK_DGRAM (** The multicast request type *) type mreq = { imr_multiaddr: Cf_ip4_addr.multicast Cf_ip4_addr.t; imr_interface: Cf_ip4_addr.unicast Cf_ip4_addr.t; } (** {6 Socket Options} The following socket options are available on sockets of AF_INET family. *) (** Set the unicast hop count for the socket. *) val ip_ttl: (int, [ `AF_INET ], 'st) Cf_socket.sockopt (** Add the socket to the membership of a multicast group. *) val ip_add_membership: (mreq, [ `AF_INET ], [ `SOCK_DGRAM ]) Cf_socket.sockopt (** Drop the socket from the membership of a multicast group. *) val ip_drop_membership: (mreq, [ `AF_INET ], [ `SOCK_DGRAM ]) Cf_socket.sockopt (** The primary network interface address for sending to multicast destinations. *) val ip_multicast_if: (Cf_ip4_addr.unicast Cf_ip4_addr.t, [ `AF_INET ], [ `SOCK_DGRAM ]) Cf_socket.sockopt (** The multicast hop count for the socket. *) val ip_multicast_ttl: (int, [ `AF_INET ], [ `SOCK_DGRAM ]) Cf_socket.sockopt (** Enable multicast loopback on the socket. *) val ip_multicast_loop: (bool, [ `AF_INET ], [ `SOCK_DGRAM ]) Cf_socket.sockopt (** {6 Other Functions} The following socket options are available on sockets of AF_INET and AF_INET6 address/protocol families. *) (** Use [siocgifaddr sock name] with any [`AF_INET] address family socket [sock] to get the primary IP address for the [name] interface. *) val siocgifaddr: ([ `AF_INET ], 'st) Cf_socket.t -> string -> [> Cf_ip4_addr.unicast ] Cf_ip4_addr.t (*--- End of File [ cf_ip4_proto.mli ] ---*) cf-0.10/cf_ip4_proto_p.c0000644000175000017500000002773110404616701015001 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_ip4_proto_p.c Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_ip4_proto_p.h" #include #include #include #include #include #define FAILWITH(S) (failwith("Cf_ip4_proto." S)) #define INVALID_ARGUMENT(S) (invalid_argument("Cf_ip4_proto." S)) static int cf_ip4_proto_sockaddr_compare(value v1, value v2) { CAMLparam2(v1, v2); const struct sockaddr_in* sinAddr1Ptr; const struct sockaddr_in* sinAddr2Ptr; const u_int8_t* addr1Ptr; const u_int8_t* addr2Ptr; int i, result; sinAddr1Ptr = &Cf_socket_sockaddrx_val(in, v1)->sx_sockaddr_in; sinAddr2Ptr = &Cf_socket_sockaddrx_val(in, v2)->sx_sockaddr_in; addr1Ptr = (u_int8_t*)(sinAddr1Ptr->sin_addr.s_addr) + 3; addr2Ptr = (u_int8_t*)(sinAddr2Ptr->sin_addr.s_addr) + 3; for (i = 4; i >= 0; --i, --addr1Ptr, --addr2Ptr) { result = *addr1Ptr - *addr2Ptr; if (result) goto done; } addr1Ptr = (u_int8_t*) &(sinAddr1Ptr->sin_port) + 1; addr2Ptr = (u_int8_t*) &(sinAddr2Ptr->sin_port) + 1; for (i = 2; i >= 0; --i, --addr1Ptr, --addr2Ptr) { result = *addr1Ptr - *addr2Ptr; if (result) goto done; } done: CAMLreturn(result); } static long cf_ip4_proto_sockaddr_hash(value sxVal) { CAMLparam1(sxVal); const struct sockaddr_in* sinPtr; long result; sinPtr = &Cf_socket_sockaddrx_val(in, sxVal)->sx_sockaddr_in; result = (long) ntohl(sinPtr->sin_addr.s_addr); result ^= ntohs(sinPtr->sin_port); CAMLreturn(result); } static void cf_ip4_proto_sockaddr_serialize (value sxVal, unsigned long* size32Ptr, unsigned long* size64Ptr) { CAMLparam1(sxVal); const struct sockaddr_in* sinPtr; sinPtr = &Cf_socket_sockaddrx_val(in, sxVal)->sx_sockaddr_in; serialize_int_4(ntohl(sinPtr->sin_addr.s_addr)); serialize_int_2(ntohs(sinPtr->sin_port)); *size32Ptr = sizeof *sinPtr; *size64Ptr = sizeof *sinPtr; CAMLreturn0; } static unsigned long cf_ip4_proto_sockaddr_deserialize(void* bufferPtr) { struct sockaddr_in* sinPtr; sinPtr = (struct sockaddr_in*) bufferPtr; sinPtr->sin_family = AF_INET; sinPtr->sin_addr.s_addr = deserialize_uint_4(); sinPtr->sin_addr.s_addr = htonl(sinPtr->sin_addr.s_addr); sinPtr->sin_port = deserialize_uint_2(); sinPtr->sin_port = htons(sinPtr->sin_port); return sizeof *sinPtr; } static struct custom_operations cf_ip4_proto_sockaddr_op = { "org.conjury.ocnae.cf.sockaddr_in", custom_finalize_default, cf_ip4_proto_sockaddr_compare, cf_ip4_proto_sockaddr_hash, cf_ip4_proto_sockaddr_serialize, cf_ip4_proto_sockaddr_deserialize }; value cf_ip4_proto_sockaddr_cons(const struct sockaddr* saPtr, size_t saLen) { value sxVal; Cf_socket_sockaddrx_in_t* sxPtr; const size_t sxLen = offsetof(Cf_socket_sockaddrx_in_t, sx_sockaddr_in) + sizeof(struct sockaddr_in); sxVal = alloc_custom(&cf_ip4_proto_sockaddr_op, sxLen, 0, 1); sxPtr = Cf_socket_sockaddrx_val(in, sxVal); if (sxPtr) { sxPtr->sx_socklen = saLen; memcpy(&sxPtr->sx_sockaddr_in, saPtr, saLen); } return sxVal; } static value cf_ip4_proto_domain_val = Val_unit; /*--- external domain_: unit -> 'a Cf_socket.domain_t = "cf_ip4_proto_domain" ---*/ CAMLprim value cf_ip4_proto_domain(value unit) { CAMLparam0(); CAMLreturn(cf_ip4_proto_domain_val); } /*--- external to_sockaddr: Cf_ip4_addr.opaque Cf_ip4_addr.t * int -> [`AF_INET] Cf_socket.sockaddr_t = "cf_ip4_proto_to_sockaddr" ---*/ CAMLprim value cf_ip4_proto_to_sockaddr(value addrVal) { CAMLparam1(addrVal); CAMLlocal1(resultVal); struct sockaddr_in sin; int port; port = Int_val(Field(addrVal, 1)); if (port < 0 || port > 65535) INVALID_ARGUMENT("to_sockaddr: invalid port number"); memset(&sin, 0, sizeof sin); sin.sin_family = AF_INET; sin.sin_port = htons(port); sin.sin_addr = *Cf_ip4_addr_val(Field(addrVal, 0)); resultVal = cf_ip4_proto_sockaddr_cons((struct sockaddr*) &sin, sizeof sin); CAMLreturn(resultVal); } /*--- external of_sockaddr: [`AF_INET] Cf_socket.sockaddr_t -> Cf_ip4_addr.opaque Cf_ip4_addr.t * int = "cf_ip4_proto_of_sockaddr" ---*/ CAMLprim value cf_ip4_proto_of_sockaddr(value sxVal) { CAMLparam1(sxVal); CAMLlocal2(addrVal, resultVal); const Cf_socket_sockaddrx_in_t* sxPtr; const struct sockaddr_in* sinPtr; sxPtr = Cf_socket_sockaddrx_val(in, sxVal); sinPtr = &sxPtr->sx_sockaddr_in; addrVal = cf_ip4_addr_alloc(&sinPtr->sin_addr); resultVal = alloc_small(2, 0); Field(resultVal, 0) = addrVal; Field(resultVal, 1) = Val_int(ntohs(sinPtr->sin_port)); CAMLreturn(resultVal); } /*--- external siocgifaddr: ([ `AF_INET ], 'st) Cf_socket.t -> string -> [> Cf_ip4_addr.unicast ] Cf_ip4_addr.t = "cf_ip4_proto_siocgifaddr" ---*/ CAMLprim value cf_ip4_proto_siocgifaddr(value sockVal, value nameVal) { CAMLparam2(sockVal, nameVal); CAMLlocal1(resultVal); const char* namePtr; const Cf_socket_t* sockPtr; char buffer[IF_NAMESIZE + sizeof(struct sockaddr_storage)]; struct ifreq* ifrPtr; const struct sockaddr_in* sinPtr; int v; namePtr = String_val(nameVal); if (string_length(nameVal) > IF_NAMESIZE || strlen(namePtr) >= IF_NAMESIZE) invalid_argument("ioctl[SIOCGIFADDR]: name too long."); memset(buffer, 0, sizeof buffer); ifrPtr = (struct ifreq*) buffer; strcpy(ifrPtr->ifr_name, String_val(nameVal)); sockPtr = Cf_socket_val(sockVal); v = ioctl(sockPtr->s_fd, SIOCGIFADDR, buffer); if (v == -1) unix_error(errno, "ioctl[SIOCGIFADDR]", Nothing); sinPtr = (const struct sockaddr_in*) &ifrPtr->ifr_addr; resultVal = cf_ip4_addr_alloc(&sinPtr->sin_addr); CAMLreturn(resultVal); } value cf_ip4_proto_getsockopt_uchar (const Cf_socket_option_context_t* contextPtr) { u_char optval; socklen_t optlen; memset(&optval, 0, sizeof optval); optlen = sizeof optval; cf_socket_getsockopt_guard(contextPtr, &optval, &optlen); return Val_int(optval); } void cf_ip4_proto_setsockopt_uchar (const Cf_socket_option_context_t* contextPtr, value x) { u_char optval; int n; n = Int_val(x); if (n < 0 || n > 0xFF) invalid_argument("Cf_ip4_proto.setsockopt[uchar]: range error."); optval = n; cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval); } value cf_ip4_proto_getsockopt_addr (const Cf_socket_option_context_t* contextPtr) { struct in_addr optval; socklen_t optlen; memset(&optval, 0, sizeof optval); optlen = sizeof optval; cf_socket_getsockopt_guard(contextPtr, &optval, &optlen); return cf_ip4_addr_alloc(&optval); } void cf_ip4_proto_setsockopt_addr (const Cf_socket_option_context_t* contextPtr, value x) { struct in_addr optval; optval = *Cf_ip4_addr_val(x); cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval); } value cf_ip4_proto_getsockopt_mreq (const Cf_socket_option_context_t* contextPtr) { CAMLparam0(); CAMLlocal3(multiaddrVal, interfaceVal, resultVal); struct ip_mreq optval; socklen_t optlen; memset(&optval, 0, sizeof optval); optlen = sizeof optval; cf_socket_getsockopt_guard(contextPtr, &optval, &optlen); multiaddrVal = cf_ip4_addr_alloc(&optval.imr_multiaddr); interfaceVal = cf_ip4_addr_alloc(&optval.imr_interface); resultVal = alloc_small(2, 0); Field(resultVal, 0) = multiaddrVal; Field(resultVal, 0) = interfaceVal; CAMLreturn(resultVal); } void cf_ip4_proto_setsockopt_mreq (const Cf_socket_option_context_t* contextPtr, value x) { struct ip_mreq optval; optval.imr_multiaddr = *Cf_ip4_addr_val(Field(x, 0)); optval.imr_interface = *Cf_ip4_addr_val(Field(x, 1)); cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval); } /*--- type sockopt_index_t = IP_TTL | IP_ADD_MEMBERSHIP | IP_DROP_MEMBERSHIP | IP_MULTICAST_IF | IP_MULTICAST_TTL | IP_MULTICAST_LOOP ---*/ static Cf_socket_sockopt_lift_t cf_ip4_proto_sockopt_lift_array[] = { { /* IP_TTL */ Val_unit, { IPPROTO_IP, IP_TTL, cf_socket_getsockopt_int, cf_socket_setsockopt_int } }, { /* IP_ADD_MEMBERSHIP */ Val_unit, { IPPROTO_IP, IP_ADD_MEMBERSHIP, cf_ip4_proto_getsockopt_mreq, cf_ip4_proto_setsockopt_mreq } }, { /* IP_DROP_MEMBERSHIP */ Val_unit, { IPPROTO_IP, IP_DROP_MEMBERSHIP, cf_ip4_proto_getsockopt_mreq, cf_ip4_proto_setsockopt_mreq } }, { /* IP_MULTICAST_IF */ Val_unit, { IPPROTO_IP, IP_MULTICAST_IF, cf_ip4_proto_getsockopt_addr, cf_ip4_proto_setsockopt_addr } }, { /* IP_MULTICAST_TTL */ Val_unit, { IPPROTO_IP, IP_MULTICAST_TTL, cf_ip4_proto_getsockopt_uchar, cf_ip4_proto_setsockopt_uchar } }, { /* IP_MULTICAST_LOOP */ Val_unit, { IPPROTO_IP, IP_MULTICAST_LOOP, cf_ip4_proto_getsockopt_uchar, cf_ip4_proto_setsockopt_uchar } }, }; #define CF_IP4_PROTO_SOCKOPT_LIFT_ARRAY_SIZE \ (sizeof cf_ip4_proto_sockopt_lift_array / \ sizeof cf_ip4_proto_sockopt_lift_array[0]) /*--- external sockopt_lift: sockopt_index_t -> ('a, 'b, 'c) Cf_socket.sockopt_t = "cf_ip4_proto_sockopt_lift" ---*/ CAMLprim value cf_ip4_proto_sockopt_lift(value indexVal) { CAMLparam1(indexVal); CAMLreturn(cf_ip4_proto_sockopt_lift_array[Int_val(indexVal)].ol_val); } /*--- Initialization primitive ---*/ CAMLprim value cf_ip4_proto_init(value unit) { int i; static Cf_socket_domain_t domain = { PF_INET, AF_INET, cf_ip4_proto_sockaddr_cons, sizeof(struct sockaddr_in) }; register_custom_operations(&cf_ip4_proto_sockaddr_op); register_global_root(&cf_ip4_proto_domain_val); cf_ip4_proto_domain_val = cf_socket_domain_alloc(&domain); for (i = 0; i < CF_IP4_PROTO_SOCKOPT_LIFT_ARRAY_SIZE; ++i) { Cf_socket_sockopt_lift_t* liftPtr; liftPtr = &cf_ip4_proto_sockopt_lift_array[i]; register_global_root(&liftPtr->ol_val); liftPtr->ol_val = cf_socket_option_alloc(&liftPtr->ol_option); } return Val_unit; } /*--- End of File [ cf_ip4_proto_p.c ] ---*/ cf-0.10/cf_ip4_proto_p.h0000644000175000017500000000336410404616701015002 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_ip4_proto_p.h Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_IP4_PROTO_P_H #define _CF_IP4_PROTO_P_H #include "cf_ip_common_p.h" Cf_socket_sockaddrx_struct(in); Cf_socket_sockaddrx_typedef(in); #endif /* defined(_CF_IP4_PROTO_P_H) */ /*--- End of File [ cf_ip4_proto_p.h ] ---*/ cf-0.10/cf_ip6_addr.ml0000644000175000017500000001034510454115143014411 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_ip6_addr.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) external init_: unit -> unit = "cf_ip6_addr_init";; init_ ();; type -'a t type opaque = [ `AF_INET6 ] type format = Unspecified | Unicast | Multicast type unspecified = [ opaque | `X ] type unicast = [ opaque | `U ] type multicast = [ opaque | `M ] external format: opaque t -> format = "cf_ip6_addr_format" external is_unicast: [> opaque ] t -> unicast t = "cf_ip6_addr_is_unicast" external is_multicast: [> opaque ] t -> multicast t = "cf_ip6_addr_is_multicast" type unicast_format = | U_unassigned | U_reserved | U_loopback | U_v4compat | U_v4mapped | U_link | U_site | U_uniqlocal | U_global external unicast_format: [> unicast] t -> unicast_format = "cf_ip6_addr_unicast_format" type v4compat = [ unicast | `V4C ] external is_v4compat: [> unicast ] t -> Cf_ip4_addr.opaque Cf_ip4_addr.t = "cf_ip6_addr_is_v4compat" external to_v4compat: [> Cf_ip4_addr.unicast ] Cf_ip4_addr.t -> v4compat t = "cf_ip6_addr_to_v4compat" type v4mapped = [ unicast | `V4M ] external is_v4mapped: [> unicast ] t -> Cf_ip4_addr.opaque Cf_ip4_addr.t = "cf_ip6_addr_is_v4mapped" external to_v4mapped: [> Cf_ip4_addr.unicast ] Cf_ip4_addr.t -> v4mapped t = "cf_ip6_addr_to_v4mapped" type multicast_flag = M_F_transient | M_F_unassigned of int type multicast_scope = | M_S_node | M_S_link | M_S_site | M_S_org | M_S_global | M_S_unassigned of int type multicast_group_id = [ opaque | `G ] external to_multicast_components: [> multicast ] t -> multicast_scope * multicast_flag list * multicast_group_id t = "cf_ip6_addr_to_multicast_components" external of_multicast_components: multicast_scope -> multicast_flag list -> multicast_group_id t -> multicast t = "cf_ip6_addr_of_multicast_components" external unspecified_: unit -> unspecified t = "cf_ip6_addr_unspecified" external loopback_: unit -> unicast t = "cf_ip6_addr_loopback" external node_local_all_nodes_: unit -> multicast t = "cf_ip6_addr_node_local_all_nodes" external link_local_all_nodes_: unit -> multicast t = "cf_ip6_addr_link_local_all_nodes" external link_local_all_routers_: unit -> multicast t = "cf_ip6_addr_link_local_all_routers" let unspecified = unspecified_ () let loopback = loopback_ () let node_local_all_nodes = node_local_all_nodes_ () let link_local_all_nodes = link_local_all_nodes_ () let link_local_all_routers = link_local_all_routers_ () external equal: ([> opaque ] t as 'a) -> 'a -> bool = "cf_ip6_addr_equal" external compare: ([> opaque ] t as 'a) -> 'a -> int = "cf_ip6_addr_compare_aux" external pton: string -> opaque t option = "cf_inet_pton6" external ntop: [> opaque ] t -> string = "cf_inet_ntop6" (*--- End of File [ cf_ip6_addr.ml ] ---*) cf-0.10/cf_ip6_addr.mli0000644000175000017500000001640410454115143014564 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_ip6_addr.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** IPv6 addresses with attribute parameters for type safety. This module implements IPv6 addresses in an abstract type suitable for use with the {!Cf_nameinfo} module, the {!Cf_socket} module and its cognates for IPv6 transports. Internally, the IPv6 address is represented as a boxed 16-byte custom block. Externally, the IPv6 address abstract type is parameterized with a shadow attribute that constrains how it may be used depending on its address format. *) (** The type of IPv4 addresses, parameterized by address format attribute. *) type -'a t (** The shadow attribute type of IPv6 addresses of unknown format. *) type opaque = [ `AF_INET6 ] (** The type of IPv6 address formats. *) type format = | Unspecified (** ::0 *) | Unicast (** ::1 to EFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF *) | Multicast (** FF00::0 to FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF:FFFF *) (** The shadow attribute of the IPv6 unspecified address. *) type unspecified = [ opaque | `X ] (** The shadow attribute of unicast IPv6 addresses. *) type unicast = [ opaque | `U ] (** The shadow attribute of multicast IPv6 addresses. *) type multicast = [ opaque | `M ] (** Use [format a] to obtain the address format of the IPv6 address [a]. *) val format: opaque t -> format (** Use [is_unicast a] to validate that the IPv6 address [a] is a unicast address. Raises [Failure] unless the address is a unicast address. *) val is_unicast: [> opaque ] t -> unicast t (** Use [is_multicast a] to validate that the IPv6 address [a] is a multicast address. Raises [Failure] unless the address is a multicast address. *) val is_multicast: [> opaque ] t -> multicast t (** The type of unicast address formats. *) type unicast_format = | U_unassigned (** No format assigned. *) | U_reserved (** Format is reserved for future assignment. *) | U_loopback (** Loopback addresses. *) | U_v4compat (** Compatible with IPv4 (deprecated). *) | U_v4mapped (** IPv4 addresses mapped into IPv6 addresses. *) | U_link (** Link-local scope *) | U_site (** Site-local scope (deprecated). *) | U_uniqlocal (** Unique local unicast (global scope). *) | U_global (** Global scope. *) (** Use [unicast_format a] to obtain the unicast format of the unicast IPv6 address [a]. *) val unicast_format: [> unicast ] t -> unicast_format (** The shadow attribute of "v4-compat" unicast addresses *) type v4compat = [ unicast | `V4C ] (** Use [is_v4compat a] to obtain the opaque IPv4 address corresponding to the v4-compat IPv6 address. Raises [Failure] if the address is not a v4-compat format address. *) val is_v4compat: [> unicast ] t -> Cf_ip4_addr.opaque Cf_ip4_addr.t (** Use [to_v4compat a] to convert the unicast IPv4 address [a] to its v4-compat IPv6 address. *) val to_v4compat: [> Cf_ip4_addr.unicast ] Cf_ip4_addr.t -> v4compat t (** The shadow attribute of "v4-mapped" unicast addresses *) type v4mapped = [ unicast | `V4M ] (** Use [is_v4mapped a] to obtain the opaque IPv4 address corresponding to the v4-mapped IPv6 address. Raises [Failure] if the address is not a v4-mapped format address. *) val is_v4mapped: [> unicast ] t -> Cf_ip4_addr.opaque Cf_ip4_addr.t (** Use [to_v4mapped a] to convert the unicast IPv4 address [a] to its v4-mapped IPv6 address. *) val to_v4mapped: [> Cf_ip4_addr.unicast ] Cf_ip4_addr.t -> v4mapped t (** The type of IPv6 multicast address format flags. *) type multicast_flag = | M_F_transient (** Address is transiently allocated. *) | M_F_unassigned of int (** Flag is reserved for future assignment. *) (** The type of IPv6 multicast address scopes. *) type multicast_scope = | M_S_node (** Node-only scope. *) | M_S_link (** Link-local scope. *) | M_S_site (** Site-local scope. *) | M_S_org (** Organization-local scope. *) | M_S_global (** Global scope. *) | M_S_unassigned of int (** Scope reserved for future assignment. *) (** The shadow attribute of multicast group identifiers. *) type multicast_group_id = [ opaque | `G ] (** Use [to_multicast_components a] to obtain the scope, flags and group id of the IPv6 multicast address [a]. *) val to_multicast_components: [> multicast ] t -> multicast_scope * multicast_flag list * multicast_group_id t (** Use [of_multicast_components scope flags gid] to compose an IPv6 multicast address from the [scope], [flags] and [gid] components. *) val of_multicast_components: multicast_scope -> multicast_flag list -> multicast_group_id t -> multicast t (** The unspecified IPv6 address, i.e. ::0 *) val unspecified: unspecified t (** The default loopback IPv6 unicast address, i.e. ::1 *) val loopback: unicast t (** The node-local all-nodes multicast address, i.e. ff01::1 *) val node_local_all_nodes: multicast t (** The link-local all-nodes multicast address, i.e. ff02::1 *) val link_local_all_nodes: multicast t (** The link-local all-routers multicast address, i.e. ff02::2 *) val link_local_all_routers: multicast t (** Use [equal a1 a2] to compare two IPv6 addresses for equality. *) val equal: [> opaque ] t -> [> opaque ] t -> bool (** Use [compare a1 a2] to compare the ordinality of two IPv6 addresses. *) val compare: [> opaque ] t -> [> opaque ] t -> int (** Use [pton s] to convert the string [s] containing an IPv6 address in numeric format to its equivalent opaque IPv6 address. Returns [None] if the string is not in canonical numeric format. *) val pton: string -> opaque t option (** Use [ntop a] to obtain a string representation of the IPv6 address [a] in canonical numeric format. *) val ntop: [> opaque ] t -> string (*--- End of File [ cf_af_inet6.mli ] ---*) cf-0.10/cf_ip6_addr_p.c0000644000175000017500000004374710454115143014556 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_ip6_addr_p.c Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_ip6_addr_p.h" #include #include #include #define FAILWITH(S) (failwith("Cf_ip6_addr." S)) #define INVALID_ARGUMENT(S) (invalid_argument("Cf_ip6_addr." S)) enum cf_ip6_addr_format { Cf_ip6_addr_unspecified, Cf_ip6_addr_unicast, Cf_ip6_addr_multicast }; enum cf_ip6_addr_unicast_format { Cf_ip6_addr_U_unassigned, Cf_ip6_addr_U_reserved, Cf_ip6_addr_U_loopback, Cf_ip6_addr_U_v4compat, Cf_ip6_addr_U_v4mapped, Cf_ip6_addr_U_link, Cf_ip6_addr_U_site, Cf_ip6_addr_U_uniqlocal, Cf_ip6_addr_U_global }; enum cf_ip6_addr_multicast_flag { /* constant constructors */ Cf_ip6_addr_M_F_transient = 0, /* non-constant constructors */ Cf_ip6_addr_M_F_unassigned = 0 }; enum cf_ip6_addr_multicast_scope { /* constant constructors */ Cf_ip6_addr_M_S_node = 0, Cf_ip6_addr_M_S_link, Cf_ip6_addr_M_S_site, Cf_ip6_addr_M_S_org, Cf_ip6_addr_M_S_global, /* non-constant constructors */ Cf_ip6_addr_M_S_unassigned = 0 }; static const int cf_ip6_addr_multicast_scope_array[] = { /* Cf_ip6_addr_M_S_node */ 1, /* Cf_ip6_addr_M_S_link */ 2, /* Cf_ip6_addr_M_S_site */ 5, /* Cf_ip6_addr_M_S_org */ 8, /* Cf_ip6_addr_M_S_global */ 14, }; static value cf_ip6_addr_alloc_constructor_0(int n) { value v = alloc_small(1, 0); Store_field(v, 0, Int_val(n)); return v; } static const Cf_constant_table_t cf_ip6_addr_multicast_scope_table = { cf_ip6_addr_multicast_scope_array, sizeof cf_ip6_addr_multicast_scope_array / sizeof (int), cf_ip6_addr_alloc_constructor_0 }; static int cf_ip6_addr_compare(value v1, value v2) { CAMLparam2(v1, v2); const u_int8_t* addr1Ptr; const u_int8_t* addr2Ptr; int i, result; addr1Ptr = &Cf_ip6_addr_val(v1)->s6_addr[15]; addr2Ptr = &Cf_ip6_addr_val(v2)->s6_addr[15]; for (i = 15; i >= 0; --i, --addr1Ptr, --addr2Ptr) { result = *addr1Ptr - *addr2Ptr; if (result) break; } CAMLreturn(result); } static long cf_ip6_addr_hash(value v) { CAMLparam1(v); long result; const u_int32_t* u32Ptr; u_int32_t hash, x; u32Ptr = (const u_int32_t*) Cf_ip6_addr_val(v)->s6_addr; hash = 0; hash ^= (x = *u32Ptr++, ntohl(x)); hash ^= (x = *u32Ptr++, ntohl(x)); hash ^= (x = *u32Ptr++, ntohl(x)); hash ^= (x = *u32Ptr, ntohl(x)); result = (long) hash; CAMLreturn(result); } static void cf_ip6_addr_serialize (value v, unsigned long* size32Ptr, unsigned long* size64Ptr) { CAMLparam1(v); serialize_block_1(Cf_ip6_addr_val(v)->s6_addr, 16); *size32Ptr = 16; *size64Ptr = 16; CAMLreturn0; } static unsigned long cf_ip6_addr_deserialize(void* bufferPtr) { deserialize_block_1(bufferPtr, 16); return 16; } static struct custom_operations cf_ip6_addr_op = { "org.conjury.ocnae.cf.in6_addr", custom_finalize_default, cf_ip6_addr_compare, cf_ip6_addr_hash, cf_ip6_addr_serialize, cf_ip6_addr_deserialize }; value cf_ip6_addr_alloc(const struct in6_addr* addrPtr) { value result; result = alloc_custom(&cf_ip6_addr_op, 16, 0, 1); *Cf_ip6_addr_val(result) = *addrPtr; return result; } static int cf_ip6_addr_format_code(const struct in6_addr* addrPtr) { int i; for (i = 0; i < 4; ++i) { u_int32_t word; const u_int32_t fp = htonl(0xFF000000); word = *(const u_int32_t*) &addrPtr->s6_addr[i * 4]; if (!i && (word & fp) == fp) return Cf_ip6_addr_multicast; if (i < 3 && !!word) break; if (i == 3 && !word) return Cf_ip6_addr_unspecified; } return Cf_ip6_addr_unicast; } /*--- external format: opaque t -> format = "cf_ip6_addr_format" ---*/ CAMLprim value cf_ip6_addr_format(value addr) { CAMLparam1(addr); CAMLreturn(Val_int(cf_ip6_addr_format_code(Cf_ip6_addr_val(addr)))); } /*--- external is_unicast: [> opaque ] t -> unicast t = "cf_ip6_addr_is_unicast" ---*/ CAMLprim value cf_ip6_addr_is_unicast(value addr) { CAMLparam1(addr); const struct in6_addr* addr6Ptr = Cf_ip6_addr_val(addr); if (cf_ip6_addr_format_code(addr6Ptr) != Cf_ip6_addr_unicast) FAILWITH("is_unicast"); CAMLreturn(addr); } /*--- external is_multicast: [> opaque ] t -> multicast t = "cf_ip6_addr_is_multicast" ---*/ CAMLprim value cf_ip6_addr_is_multicast(value addr) { CAMLparam1(addr); const struct in6_addr* addr6Ptr = Cf_ip6_addr_val(addr); if (cf_ip6_addr_format_code(addr6Ptr) != Cf_ip6_addr_multicast) FAILWITH("is_multicast"); CAMLreturn(addr); } /*--- external unicast_format: [> unicast] t -> unicast_format = "cf_ip6_addr_unicast_format" ---*/ CAMLprim value cf_ip6_addr_unicast_format(value addr) { CAMLparam1(addr); const struct in6_addr* addr6Ptr = Cf_ip6_addr_val(addr); value result = Val_int(Cf_ip6_addr_U_unassigned); u_int32_t word; word = *(const u_int32_t*) &addr6Ptr->s6_addr[0]; word = ntohl(word); if (word > 0) { u_int32_t fp3 = word >> 29; if (fp3 == 0) { unsigned int fp7 = word >> 25; if (fp7 == 1 || fp7 == 2) result = Val_int(Cf_ip6_addr_U_reserved); } else if (fp3 == 1) result = Val_int(Cf_ip6_addr_U_global); else if (fp3 == 7) { unsigned int fp8 = word >> 24; if (fp8 == 0) result = Val_int(Cf_ip6_addr_U_reserved); else if (fp8 == 0xFE) { unsigned int fp10 = (word >> 22) & 3; if (fp10 == 2) result = Val_int(Cf_ip6_addr_U_link); else if (fp10 == 3) result = Val_int(Cf_ip6_addr_U_site); } else if (fp8 == 0xFC || fp8 == 0xFD) result = Val_int(Cf_ip6_addr_U_uniqlocal); } } else /* word == 0 */ { int i; result = Val_int(Cf_ip6_addr_U_reserved); for (i = 1; i < 3; ++i) { word = *(const u_int32_t*) &addr6Ptr->s6_addr[i * 4]; if (i == 1 && !!word) break; if (i == 2) { const struct in_addr* addr4Ptr; if (word && word != ntohl(0xFFFF)) break; addr4Ptr = (const struct in_addr*) &addr6Ptr->s6_addr[12]; if (!word && addr4Ptr->s_addr == ntohl(1)) { result = Val_int(Cf_ip6_addr_U_loopback); break; } if ( cf_ip4_addr_category_code(addr4Ptr) == Cf_ip4_addr_unicast ) { result = word ? Val_int(Cf_ip6_addr_U_v4mapped) : Val_int(Cf_ip6_addr_U_v4compat); break; } } } } CAMLreturn(result); } /*--- external is_v4compat: [> opaque ] t -> Cf_ip4_addr.opaque t = "cf_ip6_addr_is_v4compat" ---*/ CAMLprim value cf_ip6_addr_is_v4compat(value addr) { CAMLparam1(addr); const struct in6_addr* addr6Ptr = Cf_ip6_addr_val(addr); struct in_addr addr4; if (!IN6_IS_ADDR_V4COMPAT(addr6Ptr)) FAILWITH("is_v4compat"); addr4.s_addr = *(const u_int32_t*)(&addr6Ptr->s6_addr[12]); CAMLreturn(cf_ip4_addr_alloc(&addr4)); } /*--- external to_v4compat: [> Cf_ip4_addr.unicast ] -> v4compat t = "cf_ip6_addr_to_v4compat" ---*/ CAMLprim value cf_ip6_addr_is_v4mapped(value addr) { CAMLparam1(addr); const struct in6_addr* addr6Ptr = Cf_ip6_addr_val(addr); struct in_addr addr4; if (!IN6_IS_ADDR_V4MAPPED(addr6Ptr)) FAILWITH("is_v4mapped"); addr4.s_addr = *(const u_int32_t*)(&addr6Ptr->s6_addr[12]); CAMLreturn(cf_ip4_addr_alloc(&addr4)); } /*--- external is_v4mapped: [> opaque ] t -> Cf_ip4_addr.opaque t = "cf_ip6_addr_is_v4mapped" ---*/ CAMLprim value cf_ip6_addr_to_v4compat(value addr4) { CAMLparam1(addr4); const struct in_addr* addrPtr = Cf_ip4_addr_val(addr4); struct in6_addr addr6; addr6 = in6addr_any; *((u_int32_t*) &addr6.s6_addr[0]) = 0; *((u_int32_t*) &addr6.s6_addr[4]) = 0; *((u_int32_t*) &addr6.s6_addr[8]) = 0; *((u_int32_t*) &addr6.s6_addr[12]) = addrPtr->s_addr; CAMLreturn(cf_ip6_addr_alloc(&addr6)); } /*--- external to_v4mapped: [> Cf_ip4_addr.unicast ] -> v4mapped t = "cf_ip6_addr_to_v4mapped" ---*/ CAMLprim value cf_ip6_addr_to_v4mapped(value addr4) { CAMLparam1(addr4); const struct in_addr* addrPtr = Cf_ip4_addr_val(addr4); struct in6_addr addr6; addr6 = in6addr_any; *((u_int32_t*) &addr6.s6_addr[0]) = 0; *((u_int32_t*) &addr6.s6_addr[4]) = 0; *((u_int32_t*) &addr6.s6_addr[8]) = htonl(0xFFFF); *((u_int32_t*) &addr6.s6_addr[12]) = addrPtr->s_addr; CAMLreturn(cf_ip6_addr_alloc(&addr6)); } #ifndef IN6ADDR_NODELOCAL_ALLNODES_INIT #define IN6ADDR_NODELOCAL_ALLNODES_INIT \ {{{ 0xff, 0x01, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, \ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01 }}} #endif #ifndef IN6ADDR_LINKLOCAL_ALLNODES_INIT #define IN6ADDR_LINKLOCAL_ALLNODES_INIT \ {{{ 0xff, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, \ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x01 }}} #endif #ifndef IN6ADDR_LINKLOCAL_ALLROUTERS_INIT #define IN6ADDR_LINKLOCAL_ALLROUTERS_INIT \ {{{ 0xff, 0x02, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, \ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x02 }}} #endif static const struct in6_addr cf_in6addr_nodelocal_allnodes = IN6ADDR_NODELOCAL_ALLNODES_INIT; static const struct in6_addr cf_in6addr_linklocal_allnodes = IN6ADDR_LINKLOCAL_ALLNODES_INIT; static const struct in6_addr cf_in6addr_linklocal_allrouters = IN6ADDR_LINKLOCAL_ALLROUTERS_INIT; static value cf_ip6_addr_unspecified_val = Val_unit; static value cf_ip6_addr_loopback_val = Val_unit; static value cf_ip6_addr_node_local_all_nodes_val = Val_unit; static value cf_ip6_addr_link_local_all_nodes_val = Val_unit; static value cf_ip6_addr_link_local_all_routers_val = Val_unit; /*--- external to_multicast_components: [> multicast ] t -> multicast_scope * multicast_flag list * multicast_group_id t = "cf_ip6_addr_to_multicast_components" ---*/ CAMLprim value cf_ip6_addr_to_multicast_components(value addrVal) { CAMLparam1(addrVal); CAMLlocal5(resultVal, scopeVal, flagListVal, groupIdVal, hdVal); CAMLlocal1(consVal); const struct in6_addr* addrPtr = Cf_ip6_addr_val(addrVal); struct in6_addr groupId; u_int32_t word; int i; word = *(const u_int32_t*) addrPtr->s6_addr; word = ntohl(word); scopeVal = cf_get_constant (&cf_ip6_addr_multicast_scope_table, (word >> 16) & 0xF); flagListVal = Val_int(0); for (i = 0; i < 4; ++i) { if (word & (0x100000 << i)) { hdVal = alloc_small(2, 0); if (i == 0) Store_field(hdVal, 0, Val_int(0)); else { consVal = alloc_small(1, 0); Store_field(consVal, 0, Val_int(i)); Store_field(hdVal, 0, consVal); } Store_field(hdVal, 1, flagListVal); flagListVal = hdVal; } } groupId.s6_addr[0] = 0; groupId.s6_addr[1] = 0; memcpy(&groupId.s6_addr[2], &addrPtr->s6_addr[2], 14); groupIdVal = cf_ip6_addr_alloc(&groupId); resultVal = alloc_small(3, 0); Store_field(resultVal, 0, scopeVal); Store_field(resultVal, 1, flagListVal); Store_field(resultVal, 2, groupIdVal); CAMLreturn(resultVal); } /*--- external of_multicast_components: multicast_scope -> multicast_flag list -> multicast_group_id t -> multicast t = "cf_ip6_addr_of_multicast_components" ---*/ CAMLprim value cf_ip6_addr_of_multicast_components (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)) { flagVal = Field(flagListVal, 0); if (Is_block(flagVal)) { int unassigned; consVal = Field(0, flagVal); unassigned = Int_val(consVal); if (unassigned < 0 || unassigned > 3) INVALID_ARGUMENT("of_multicast_components"); byte |= 0x10 << unassigned; } else byte |= 0x10 << Int_val(flagVal); flagListVal = Field(flagListVal, 1); } byte |= cf_ip6_addr_multicast_scope_table.array[Int_val(scopeVal)]; addr.s6_addr[1] = byte; memcpy(&addr.s6_addr[2], &Cf_ip6_addr_val(groupIdVal)->s6_addr[2], 14); CAMLreturn(cf_ip6_addr_alloc(&addr)); } /*--- external unspecified_: unit -> unspecified t = "cf_ip6_addr_unspecified" ---*/ CAMLprim value cf_ip6_addr_unspecified(value unit) { CAMLparam0(); CAMLreturn(cf_ip6_addr_unspecified_val); } /*--- external loopback_: unit -> unicast t = "cf_ip6_addr_loopback" ---*/ CAMLprim value cf_ip6_addr_loopback(value unit) { CAMLparam0(); CAMLreturn(cf_ip6_addr_loopback_val); } /*--- external node_local_all_nodes_: unit -> multicast t = "cf_ip6_addr_node_local_all_nodes" ---*/ CAMLprim value cf_ip6_addr_node_local_all_nodes(value unit) { CAMLparam0(); CAMLreturn(cf_ip6_addr_node_local_all_nodes_val); } /*--- external link_local_all_nodes_: unit -> multicast t = "cf_ip6_addr_link_local_all_nodes" ---*/ CAMLprim value cf_ip6_addr_link_local_all_nodes(value unit) { CAMLparam0(); CAMLreturn(cf_ip6_addr_link_local_all_nodes_val); } /*--- external link_local_all_routers_: unit -> multicast t = "cf_ip6_addr_link_local_all_routers" ---*/ CAMLprim value cf_ip6_addr_link_local_all_routers(value unit) { CAMLparam0(); CAMLreturn(cf_ip6_addr_link_local_all_routers_val); } /*--- external equal: [> opaque ] t -> [> opaque ] t -> bool = "cf_ip6_addr_equal" ---*/ CAMLprim value cf_ip6_addr_equal(value addr1, value addr2) { CAMLparam2(addr1, addr2); value result; if (IN6_ARE_ADDR_EQUAL(Cf_ip6_addr_val(addr1), Cf_ip6_addr_val(addr2))) result = Val_true; else result = Val_false; CAMLreturn(result); } /*--- external compare: [> opaque ] t -> [> opaque ] t -> int = "cf_ip6_addr_compare_aux" ---*/ CAMLprim value cf_ip6_addr_compare_aux(value v1, value v2) { int d = cf_ip6_addr_compare(v1, v2); return Val_int(d); } /*--- external pton: string -> opaque t option = "cf_inet_pton6" ---*/ CAMLprim value cf_inet_pton6(value str) { CAMLparam1(str); CAMLlocal1(resultVal); struct in6_addr addr; int result; result = inet_pton(AF_INET6, String_val(str), &addr); if (result < 0) failwith("inet_pton(AF_INET6, ...)"); resultVal = Val_int(0); if (result > 0) { resultVal = alloc_small(1, 0); Store_field(resultVal, 0, cf_ip6_addr_alloc(&addr)); } CAMLreturn(resultVal); } /*--- external ntop: [> opaque ] t -> string = "cf_inet_ntop6" ---*/ CAMLprim value cf_inet_ntop6(value str) { CAMLparam1(str); char buffer[INET6_ADDRSTRLEN]; if (inet_ntop(AF_INET6, Cf_ip6_addr_val(str), buffer, sizeof buffer) == 0) failwith("inet_ntop(AF_INET6, ....)"); CAMLreturn(copy_string(buffer)); } /*--- Initialization primitive ---*/ CAMLprim value cf_ip6_addr_init(value unit) { register_custom_operations(&cf_ip6_addr_op); register_global_root(&cf_ip6_addr_unspecified_val); cf_ip6_addr_unspecified_val = cf_ip6_addr_alloc(&in6addr_any); register_global_root(&cf_ip6_addr_loopback_val); cf_ip6_addr_loopback_val = cf_ip6_addr_alloc(&in6addr_loopback); register_global_root(&cf_ip6_addr_node_local_all_nodes_val); cf_ip6_addr_node_local_all_nodes_val = cf_ip6_addr_alloc(&cf_in6addr_nodelocal_allnodes); register_global_root(&cf_ip6_addr_link_local_all_nodes_val); cf_ip6_addr_link_local_all_nodes_val = cf_ip6_addr_alloc(&cf_in6addr_linklocal_allnodes); register_global_root(&cf_ip6_addr_link_local_all_routers_val); cf_ip6_addr_link_local_all_routers_val = cf_ip6_addr_alloc(&cf_in6addr_linklocal_allrouters); return Val_unit; } /*--- End of File [ cf_ip6_addr_p.c ] ---*/ cf-0.10/cf_ip6_addr_p.h0000644000175000017500000000351210404616701014546 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_ip6_addr_p.h Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_IP6_ADDR_P_H #define _CF_IP6_ADDR_P_H #include "cf_common_p.h" #include "cf_ip4_addr_p.h" #define Cf_ip6_addr_val(v) ((struct in6_addr*) Data_custom_val(v)) extern value cf_ip6_addr_alloc(const struct in6_addr* addrPtr); #endif /* defined(_CF_IP6_ADDR_P_H) */ /*--- End of File [ cf_ip6_addr_p.h ] ---*/ cf-0.10/cf_ip6_proto.ml0000644000175000017500000000636610433520572014655 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_ip6_proto.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) external init_: unit -> unit = "cf_ip6_proto_init";; init_ ();; external domain_: unit -> 'a Cf_socket.domain = "cf_ip6_proto_domain" module AF = struct type tag = [ `AF_INET6 ] type address = Cf_ip6_addr.opaque Cf_ip6_addr.t * int * int32 let domain = domain_ () external to_sockaddr: address -> tag Cf_socket.sockaddr = "cf_ip6_proto_to_sockaddr" external of_sockaddr: tag Cf_socket.sockaddr -> address = "cf_ip6_proto_of_sockaddr" let unspecified = let any = (Cf_ip6_addr.unspecified :> Cf_ip6_addr.opaque Cf_ip6_addr.t) in to_sockaddr (any, 0, 0l) end module TCP = struct module AF = AF module ST = Cf_socket.SOCK_STREAM let protocol = Cf_ip_common.zero end module UDP = struct module AF = AF module ST = Cf_socket.SOCK_DGRAM let protocol = Cf_ip_common.zero end type mreq = { ipv6mr_multiaddr: Cf_ip4_addr.multicast Cf_ip4_addr.t; ipv6mr_interface: int; } type sockopt_index = IPV6_UNICAST_HOPS | IPV6_V6ONLY | IPV6_JOIN_GROUP | IPV6_LEAVE_GROUP | IPV6_MULTICAST_IF | IPV6_MULTICAST_HOPS | IPV6_MULTICAST_LOOP external sockopt_lift: sockopt_index -> ('v,[`AF_INET6],'st) Cf_socket.sockopt = "cf_ip6_proto_sockopt_lift" let ipv6_unicast_hops = Obj.magic (sockopt_lift IPV6_UNICAST_HOPS) let ipv6_v6only = Obj.magic (sockopt_lift IPV6_V6ONLY) let ipv6_join_group = Obj.magic (sockopt_lift IPV6_JOIN_GROUP) let ipv6_leave_group = Obj.magic (sockopt_lift IPV6_LEAVE_GROUP) let ipv6_multicast_if = Obj.magic (sockopt_lift IPV6_MULTICAST_IF) let ipv6_multicast_hops = Obj.magic (sockopt_lift IPV6_MULTICAST_HOPS) let ipv6_multicast_loop = Obj.magic (sockopt_lift IPV6_MULTICAST_LOOP) (*--- End of File [ cf_ip6_proto.ml ] ---*) cf-0.10/cf_ip6_proto.mli0000644000175000017500000000640610433520572015021 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_ip6_proto.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** The [AF_INET6] address family (for use with TCP and UDP over IPv6). *) (** {6 Modules and Types} *) (** The address family module for IPv6 transports. *) module AF: Cf_socket.AF with type tag = [ `AF_INET6 ] and type address = Cf_ip6_addr.opaque Cf_ip6_addr.t * int * int32 (** The TCP (IPv6) socket protocol. *) module TCP: Cf_socket.P with module AF = AF and module ST = Cf_socket.SOCK_STREAM (** The UDP (IPv6) socket protocol. *) module UDP: Cf_socket.P with module AF = AF and module ST = Cf_socket.SOCK_DGRAM (** The multicast request type *) type mreq = { ipv6mr_multiaddr: Cf_ip4_addr.multicast Cf_ip4_addr.t; ipv6mr_interface: int; } (** {6 Socket Options} The following socket options are available on sockets of AF_INET6 family. *) (** Set the unicast hop count for the socket. *) val ipv6_unicast_hops: (int, [ `AF_INET6 ], 'st) Cf_socket.sockopt (** Set the unicast hop count for the socket. *) val ipv6_v6only: (bool, [ `AF_INET6 ], 'st) Cf_socket.sockopt (** Add the socket to the membership of a multicast group. *) val ipv6_join_group: (mreq, [ `AF_INET6 ], [ `SOCK_DGRAM ]) Cf_socket.sockopt (** Drop the socket from the membership of a multicast group. *) val ipv6_leave_group: (mreq, [ `AF_INET6 ], [ `SOCK_DGRAM ]) Cf_socket.sockopt (** The primary network interface address for sending to multicast destinations. *) val ipv6_multicast_if: (int, [ `AF_INET6 ], [ `SOCK_DGRAM ]) Cf_socket.sockopt (** The multicast hop count for the socket. *) val ipv6_multicast_hops: (int, [ `AF_INET6 ], [ `SOCK_DGRAM ]) Cf_socket.sockopt (** Enable multicast loopback on the socket. *) val ipv6_multicast_loop: (bool, [ `AF_INET6 ], [ `SOCK_DGRAM ]) Cf_socket.sockopt (*--- End of File [ cf_ip6_proto.mli ] ---*) cf-0.10/cf_ip6_proto_p.c0000644000175000017500000002467210404616701015004 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_ip6_proto_p.c Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_ip6_proto_p.h" #include #include #include #include #include #include #define FAILWITH(S) (failwith("Cf_ip6_proto." S)) #define INVALID_ARGUMENT(S) (invalid_argument("Cf_ip6_proto." S)) static int cf_ip6_proto_sockaddr_compare(value v1, value v2) { CAMLparam2(v1, v2); const struct sockaddr_in6* sinAddr1Ptr; const struct sockaddr_in6* sinAddr2Ptr; const u_int8_t* addr1Ptr; const u_int8_t* addr2Ptr; int i, result; sinAddr1Ptr = &Cf_socket_sockaddrx_val(in6, v1)->sx_sockaddr_in6; sinAddr2Ptr = &Cf_socket_sockaddrx_val(in6, v2)->sx_sockaddr_in6; result = sinAddr1Ptr->sin6_scope_id - sinAddr2Ptr->sin6_scope_id; if (result) goto done; addr1Ptr = (u_int8_t*)(sinAddr1Ptr->sin6_addr.s6_addr); addr2Ptr = (u_int8_t*)(sinAddr2Ptr->sin6_addr.s6_addr); for (i = 0; i < 16; ++i, ++addr1Ptr, ++addr2Ptr) { result = *addr1Ptr - *addr2Ptr; if (result) goto done; } addr1Ptr = (u_int8_t*) &(sinAddr1Ptr->sin6_port); addr2Ptr = (u_int8_t*) &(sinAddr2Ptr->sin6_port); for (i = 0; i < 2; ++i, ++addr1Ptr, ++addr2Ptr) { result = *addr1Ptr - *addr2Ptr; if (result) goto done; } done: CAMLreturn(result); } static long cf_ip6_proto_sockaddr_hash(value sxVal) { CAMLparam1(sxVal); const struct sockaddr_in6* sin6Ptr; long result; int i; unsigned long* p; sin6Ptr = &Cf_socket_sockaddrx_val(in6, sxVal)->sx_sockaddr_in6; result = ntohs(sin6Ptr->sin6_port); p = (unsigned long*) &sin6Ptr->sin6_addr; for (i = 0; i < 4; ++i) result ^= ntohl(p[i]); result ^= sin6Ptr->sin6_scope_id; CAMLreturn(result); } static void cf_ip6_proto_sockaddr_serialize (value sxVal, unsigned long* size32Ptr, unsigned long* size64Ptr) { CAMLparam1(sxVal); /* const */ struct sockaddr_in6* sin6Ptr; sin6Ptr = &Cf_socket_sockaddrx_val(in6, sxVal)->sx_sockaddr_in6; serialize_block_1(sin6Ptr->sin6_addr.s6_addr, 16); serialize_int_2(ntohs(sin6Ptr->sin6_port)); serialize_int_4(ntohl(sin6Ptr->sin6_scope_id)); *size32Ptr = sizeof *sin6Ptr; *size64Ptr = sizeof *sin6Ptr; CAMLreturn0; } static unsigned long cf_ip6_proto_sockaddr_deserialize(void* bufferPtr) { struct sockaddr_in6* sin6Ptr; sin6Ptr = (struct sockaddr_in6*) bufferPtr; sin6Ptr->sin6_family = AF_INET6; deserialize_block_1(sin6Ptr->sin6_addr.s6_addr, 16); sin6Ptr->sin6_port = deserialize_uint_2(); sin6Ptr->sin6_port = htons(sin6Ptr->sin6_port); sin6Ptr->sin6_scope_id = deserialize_uint_4(); sin6Ptr->sin6_scope_id = htonl(sin6Ptr->sin6_scope_id); return sizeof *sin6Ptr; } static struct custom_operations cf_ip6_proto_sockaddr_op = { "org.conjury.ocnae.cf.sockaddr_in6", custom_finalize_default, cf_ip6_proto_sockaddr_compare, cf_ip6_proto_sockaddr_hash, cf_ip6_proto_sockaddr_serialize, cf_ip6_proto_sockaddr_deserialize }; value cf_ip6_proto_sockaddr_cons(const struct sockaddr* saPtr, size_t saLen) { value sxVal; Cf_socket_sockaddrx_in6_t* sxPtr; const size_t sxLen = offsetof(Cf_socket_sockaddrx_in6_t, sx_sockaddr_in6) + sizeof(struct sockaddr_in6); sxVal = alloc_custom(&cf_ip6_proto_sockaddr_op, sxLen, 0, 1); sxPtr = Cf_socket_sockaddrx_val(in6, sxVal); if (sxPtr) { sxPtr->sx_socklen = saLen; memcpy(&sxPtr->sx_sockaddr_in6, saPtr, saLen); } return sxVal; } static value cf_ip6_proto_domain_val = Val_unit; /*--- external domain_: unit -> 'a Cf_socket.domain_t = "cf_ip6_proto_domain" ---*/ CAMLprim value cf_ip6_proto_domain(value unit) { CAMLparam0(); CAMLreturn(cf_ip6_proto_domain_val); } /*--- external to_sockaddr: Cf_ip6_addr.opaque Cf_ip6_addr.t * int * int32 -> [`AF_INET6] Cf_socket.sockaddr_t = "cf_ip6_proto_to_sockaddr" ---*/ CAMLprim value cf_ip6_proto_to_sockaddr(value addrVal) { CAMLparam1(addrVal); CAMLlocal1(resultVal); struct sockaddr_in6 sin6; int port; port = Int_val(Field(addrVal, 1)); if (port < 0 || port > 65535) INVALID_ARGUMENT("to_sockaddr: invalid port number"); memset(&sin6, 0, sizeof sin6); sin6.sin6_family = AF_INET6; sin6.sin6_port = htons(port); sin6.sin6_addr = *Cf_ip6_addr_val(Field(addrVal, 0)); sin6.sin6_scope_id = Int32_val(Field(addrVal, 2)); resultVal = cf_ip6_proto_sockaddr_cons((struct sockaddr*) &sin6, sizeof sin6); CAMLreturn(resultVal); } /*--- external of_sockaddr: [`AF_INET6] Cf_socket.sockaddr_t -> Cf_ip6_addr.opaque Cf_ip6_addr.t * int * int32 = "cf_ip6_proto_of_sockaddr" ---*/ CAMLprim value cf_ip6_proto_of_sockaddr(value sxVal) { CAMLparam1(sxVal); CAMLlocal2(addrVal, resultVal); const Cf_socket_sockaddrx_in6_t* sxPtr; const struct sockaddr_in6* sin6Ptr; sxPtr = Cf_socket_sockaddrx_val(in6, sxVal); sin6Ptr = &sxPtr->sx_sockaddr_in6; addrVal = cf_ip6_addr_alloc(&sin6Ptr->sin6_addr); resultVal = alloc_small(3, 0); Store_field(resultVal, 0, addrVal); Store_field(resultVal, 1, Val_int(ntohs(sin6Ptr->sin6_port))); Store_field(resultVal, 2, copy_int32(sin6Ptr->sin6_scope_id)); CAMLreturn(resultVal); } value cf_ip6_proto_getsockopt_mreq (const Cf_socket_option_context_t* contextPtr) { CAMLparam0(); CAMLlocal2(multiaddrVal, resultVal); struct ipv6_mreq optval; socklen_t optlen; memset(&optval, 0, sizeof optval); optlen = sizeof optval; cf_socket_getsockopt_guard(contextPtr, &optval, &optlen); multiaddrVal = cf_ip6_addr_alloc(&optval.ipv6mr_multiaddr); resultVal = alloc_small(2, 0); Store_field(resultVal, 0, multiaddrVal); Store_field(resultVal, 1, Val_int(optval.ipv6mr_interface)); CAMLreturn(resultVal); } void cf_ip6_proto_setsockopt_mreq (const Cf_socket_option_context_t* contextPtr, value x) { struct ipv6_mreq optval; optval.ipv6mr_multiaddr = *Cf_ip6_addr_val(Field(x, 0)); optval.ipv6mr_interface = Int_val(Field(x, 1)); cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval); } /*--- type sockopt_index_t = IPV6_UNICAST_HOPS | IPV6_V6ONLY | IPV6_JOIN_GROUP | IPV6_LEAVE_GROUP | IPV6_MULTICAST_IF | IPV6_MULTICAST_HOPS | IPV6_MULTICAST_LOOP ---*/ static Cf_socket_sockopt_lift_t cf_ip6_proto_sockopt_lift_array[] = { { /* IPV6_UNICAST_HOPS */ Val_unit, { IPPROTO_IPV6, IPV6_UNICAST_HOPS, cf_socket_getsockopt_int, cf_socket_setsockopt_int } }, { /* IPV6_V6ONLY */ Val_unit, { IPPROTO_IPV6, IPV6_V6ONLY, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } }, { /* IPV6_JOIN_GROUP */ Val_unit, { IPPROTO_IPV6, IPV6_JOIN_GROUP, cf_ip6_proto_getsockopt_mreq, cf_ip6_proto_setsockopt_mreq } }, { /* IPV6_LEAVE_GROUP */ Val_unit, { IPPROTO_IPV6, IPV6_LEAVE_GROUP, cf_ip6_proto_getsockopt_mreq, cf_ip6_proto_setsockopt_mreq } }, { /* IPV6_MULTICAST_IF */ Val_unit, { IPPROTO_IPV6, IPV6_MULTICAST_IF, cf_socket_getsockopt_int, cf_socket_setsockopt_int } }, { /* IPV6_MULTICAST_HOPS */ Val_unit, { IPPROTO_IPV6, IPV6_MULTICAST_HOPS, cf_socket_getsockopt_int, cf_socket_setsockopt_int } }, { /* IPV6_MULTICAST_LOOP */ Val_unit, { IPPROTO_IPV6, IPV6_MULTICAST_LOOP, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } }, }; #define CF_IP6_PROTO_SOCKOPT_LIFT_ARRAY_SIZE \ (sizeof cf_ip6_proto_sockopt_lift_array / \ sizeof cf_ip6_proto_sockopt_lift_array[0]) /*--- external sockopt_lift: sockopt_index_t -> ('a, 'b, 'c) Cf_socket.sockopt_t = "cf_ip6_proto_sockopt_lift" ---*/ CAMLprim value cf_ip6_proto_sockopt_lift(value indexVal) { CAMLparam1(indexVal); CAMLreturn(cf_ip6_proto_sockopt_lift_array[Int_val(indexVal)].ol_val); } /*--- Initialization primitive ---*/ CAMLprim value cf_ip6_proto_init(value unit) { int i; static Cf_socket_domain_t domain = { PF_INET6, AF_INET6, cf_ip6_proto_sockaddr_cons, sizeof(struct sockaddr_in6) }; register_custom_operations(&cf_ip6_proto_sockaddr_op); register_global_root(&cf_ip6_proto_domain_val); cf_ip6_proto_domain_val = cf_socket_domain_alloc(&domain); for (i = 0; i < CF_IP6_PROTO_SOCKOPT_LIFT_ARRAY_SIZE; ++i) { Cf_socket_sockopt_lift_t* liftPtr; liftPtr = &cf_ip6_proto_sockopt_lift_array[i]; register_global_root(&liftPtr->ol_val); liftPtr->ol_val = cf_socket_option_alloc(&liftPtr->ol_option); } return Val_unit; } /*--- End of File [ cf_ip6_proto_p.c ] ---*/ cf-0.10/cf_ip6_proto_p.h0000644000175000017500000000336610404616701015006 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_ip6_proto_p.h Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_IP6_PROTO_P_H #define _CF_IP6_PROTO_P_H #include "cf_ip_common_p.h" Cf_socket_sockaddrx_struct(in6); Cf_socket_sockaddrx_typedef(in6); #endif /* defined(_CF_IP6_PROTO_P_H) */ /*--- End of File [ cf_ip6_proto_p.h ] ---*/ cf-0.10/cf_ip_common.ml0000644000175000017500000000424210433520572014703 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_ip_common.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) external init_: unit -> unit = "cf_ip_common_init";; init_ ();; type protocol_number = P_zero | P_icmp | P_ipv4 | P_ipv6 | P_tcp | P_udp external protocol_: protocol_number -> Cf_socket.protocol = "cf_ip_common_protocol" let zero = protocol_ P_zero let icmp = protocol_ P_icmp let ipv4 = protocol_ P_ipv4 let ipv6 = protocol_ P_ipv6 let tcp = protocol_ P_tcp let udp = protocol_ P_udp type sockopt_index = TCP_NODELAY external sockopt_lift: sockopt_index -> ('v,[<`AF_INET|`AF_INET6],'st) Cf_socket.sockopt = "cf_ip_common_sockopt_lift" let tcp_nodelay = Obj.magic (sockopt_lift TCP_NODELAY) (*--- End of File [ cf_ip_common.ml ] ---*) cf-0.10/cf_ip_common.mli0000644000175000017500000000461610433520572015061 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_ip_common.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** The well-known protocol identifiers for IPv4 and IPv6 protocols. *) (** The unspecified Internet protocol identifier. *) val zero: Cf_socket.protocol (** The Internet Control and Management Protocol. *) val icmp: Cf_socket.protocol (** The Internet Protocol (version 4) for tunneling. *) val ipv4: Cf_socket.protocol (** The Internet Protocol (version 6) for tunneling. *) val ipv6: Cf_socket.protocol (** The Internet Transmission Control Protocol. *) val tcp: Cf_socket.protocol (** The Internet User Datagram Protocol. *) val udp: Cf_socket.protocol (** {6 Socket Options} The following socket options are available on sockets of AF_INET and AF_INET6 address/protocol families. *) (** Disables the Nagle algorithm for TCP connections. *) val tcp_nodelay: (bool, [< `AF_INET | `AF_INET6 ], [ `SOCK_STREAM ]) Cf_socket.sockopt (*--- End of File [ cf_ip_common.mli ] ---*) cf-0.10/cf_ip_common_p.c0000644000175000017500000000670310404616701015036 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_ip_common_p.c Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_ip_common_p.h" #include #include #include #include /*--- type protocol_number_t = P_zero | P_icmp | P_ipv4 | P_ipv6 | P_tcp | P_udp external protocol_: protocol_number_t -> Cf_socket.protocol_t = "cf_ip_common_protocol" ---*/ CAMLprim value cf_ip_common_protocol(value numVal) { CAMLparam1(numVal); static const int protocol[] = { /* P_zero */ 0, /* P_icmp */ IPPROTO_ICMP, /* P_ipv4 */ IPPROTO_IP, /* P_ipv6 */ IPPROTO_IPV6, /* P_tcp */ IPPROTO_TCP, /* P_udp */ IPPROTO_UDP, }; CAMLreturn(copy_nativeint(protocol[Int_val(numVal)])); } /*--- type sockopt_index_t = TCP_NODELAY ---*/ static Cf_socket_sockopt_lift_t cf_ip_common_sockopt_lift_array[] = { { /* TCP_NODELAY */ Val_unit, { IPPROTO_TCP, TCP_NODELAY, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } }, }; #define CF_IP_COMMON_SOCKOPT_LIFT_ARRAY_SIZE \ (sizeof cf_ip_common_sockopt_lift_array / \ sizeof cf_ip_common_sockopt_lift_array[0]) /*--- external sockopt_lift: sockopt_index_t -> ('a,[<`AF_INET|`AF_INET6],'c) Cf_socket.sockopt_t = "cf_ip_common_sockopt_lift" ---*/ CAMLprim value cf_ip_common_sockopt_lift(value indexVal) { CAMLparam1(indexVal); CAMLreturn(cf_ip_common_sockopt_lift_array[Int_val(indexVal)].ol_val); } /*--- Initialization primitive ---*/ CAMLprim value cf_ip_common_init(value unit) { int i; for (i = 0; i < CF_IP_COMMON_SOCKOPT_LIFT_ARRAY_SIZE; ++i) { Cf_socket_sockopt_lift_t* liftPtr; liftPtr = &cf_ip_common_sockopt_lift_array[i]; register_global_root(&liftPtr->ol_val); liftPtr->ol_val = cf_socket_option_alloc(&liftPtr->ol_option); } return Val_unit; } /*--- End of File [ cf_ip_common_p.c ] ---*/ cf-0.10/cf_ip_common_p.h0000644000175000017500000000334510404616701015042 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_ip_common_p.h Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_IP_COMMON_P_H #define _CF_IP_COMMON_P_H #include "cf_ip4_addr_p.h" #include "cf_ip6_addr_p.h" #include "cf_socket_p.h" #endif /* defined(_CF_IP_COMMON_P_H) */ /*--- End of File [ cf_ip_common_p.h ] ---*/ cf-0.10/cf_journal.ml0000644000175000017500000002162510433520572014401 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_journal.ml Copyright (c) 2004-2006, 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 private virtual 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 private virtual 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 = [ `Invalid ] type fail = [ `Fail ] type error = [ `Error ] type warn = [ `Warn ] type notice = [ `Notice ] type info = [ `Info ] type debug = [ `Debug ] type basic = [ invalid | fail | error | warn | notice | info | debug ] type enable = [ `None | `All ] type level = [ basic | enable ] end class ['level] basic_prioritizer = object inherit ['level] Basic.prioritizer constraint 'level = [> Basic.level ] method code = function | `All -> max_int | `Invalid -> 7000 | `Fail -> 6000 | `Error -> 5000 | `Warn -> 4000 | `Notice -> 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 notice_ = "NOTICE" in let info_ = "INFO" in let debug_ = "DEBUG" in function | `Invalid -> invalid_ | `Fail -> fail_ | `Error -> error_ | `Warn -> warn_ | `Notice -> notice_ | `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 ] 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 ] 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 notice: 'a. ('a, unit, string, unit) format4 -> 'a = self#put `Notice 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 Basic.event basic_channel_archiver] basic_agent basic_prioritizer `Notice [archiver] method private event = new Basic.event basic_prioritizer end type t = Basic.level Basic.event Basic.archiver basic_agent 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-0.10/cf_journal.mli0000644000175000017500000003246710433520572014560 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_journal.mli Copyright (c) 2004-2006, 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 private virtual 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=7000. *) type invalid = [ `Invalid ] (** The priority level for events indicating that an internal program function has failed, results may have been lost and recovery is not expected. Code=6000. *) type fail = [ `Fail ] (** The priority level for events indicating that a program has encountered invalid input. The program is expected to recover and continue processing further valid input correctly. Code=5000. *) type error = [ `Error ] (** The priority level for events indicating that a program has encountered unexpected input, indicating that an external process may have failed. The program is expected to continue processing further input normally. Code=4000. *) type warn = [ `Warn ] (** The priority level for events indicating exceptional information about the processing of the program useful for diagnosing external processes. Code=2000. *) type notice = [ `Notice ] (** The priority level for events indicating normal information about the processing of the program useful for diagnosing external processes. Code=2000. *) type info = [ `Info ] (** The priority level for events describing internal processing of the program for the purpose of diagnosing programming errors. Code=1000. *) type debug = [ `Debug ] (** The priority levels corresponding to events that the basic agent has public methods for journaling. *) type basic = [ invalid | fail | error | warn | notice | info | debug ] (** 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 = [ `None | `All ] (** The sum of all basic priority levels. *) type level = [ basic | enable ] 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 ] (** 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 ] #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 ] 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#notice msg ...] to format message text to put to the archivers at the [`Notice] level. *) method notice: '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 (** The type of the most basic agent, used for [stdout] and [stderr] below. *) type t = Basic.level Basic.event Basic.archiver basic_agent (** A basic agent, initially set with a limit of [`Notice], and with with one basic archiver for the [Pervasives.stdout] channel. *) val stdout: t (** A basic agent, initially set with a limit of [`Notice], and with with one basic archiver for the [Pervasives.stderr] channel. *) val stderr: t (*--- End of File [ cf_journal.mli ] ---*) cf-0.10/cf_lex.ml0000644000175000017500000000746710433520572013527 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_lex.ml Copyright (c) 2005-2006, 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. *---------------------------------------------------------------------------*) module DFA = Cf_regex.DFA type x = DFA.x type 'a r = 'a DFA.r type 'a t = 'a DFA.t let nil = DFA.nil let create r = DFA.create r module type Expr_Op_T = sig val ( $| ): x -> x -> x val ( $& ): x -> x -> x val ( !* ): x -> x val ( !+ ): x -> x val ( !? ): x -> x val ( !: ): char -> x val ( !^ ): (char -> bool) -> x val ( !~ ): char Cf_seq.t -> x val ( !$ ): string -> x end module Expr_Op = struct let ( !~ ) = Cf_regex.expr_of_seq let ( !$ ) = Cf_regex.expr_of_string end let identity_ x = x module Op = struct include DFA.Op include Expr_Op let ( $> ) e f = e $> (fun z -> f (Cf_seq.to_string z)) let ( ?~ ) e = DFA.create (e $> identity_) let ( ?$ ) s = DFA.create (Cf_regex.expr_of_string s $> identity_) end module X = struct type ('c, 'a) r = ('c, 'a) DFA.X.r type ('c, 'a) t = ('c, 'a) DFA.X.t let create r = DFA.X.create r module Op = struct include DFA.X.Op include Expr_Op let ( $> ) e f = e $> (fun z -> f (Cf_seq.to_string z)) let ( ?~ ) e = DFA.X.create (e $> identity_) let ( ?$ ) s = DFA.X.create (Cf_regex.expr_of_string s $> identity_) end end type counter = { c_pos: int; c_row: int; c_col: int; } let counter_zero = { c_pos = 0; c_row = 0; c_col = 0; } class cursor ?(c = counter_zero) newline = let nl0 = Cf_seq.to_list (Cf_seq.of_string newline) in object(self:'self) inherit [char] Cf_parser.cursor c.c_pos val row_: int = c.c_row val col_: int = c.c_col val nlz_: char list = nl0 val nl0_: char list = nl0 method counter = { c_pos = position_; c_row = row_; c_col = col_; } method row = row_ method col = col_ method private next ch = match nlz_ with | hd :: [] when ch = hd -> succ row_, 0, nl0_ | hd :: tl when ch = hd -> row_, succ col_, tl | _ -> row_, succ col_, nlz_ method advance ch = let row, col, nlz = self#next ch in {< position_ = succ position_; row_ = row; col_ = col; nlz_ = nlz; >} end (*--- End of File [ cf_lex.ml ] ---*) cf-0.10/cf_lex.mli0000644000175000017500000002552310433520572013671 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_lex.mli Copyright (c) 2005-2006, 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 of regular grammars. *) (** {6 Overview} This module implements functional parsers on octet character sequences using regular expressions and functional composition of lazy deterministic finite automata. *) (** {6 Core Interface} *) (** The type of regular expressions. *) type x = Cf_regex.DFA.x (** The type of lexical analysis rules. *) type 'a r = 'a Cf_regex.DFA.r (** Character stream parser. *) type 'a t = (char, 'a) Cf_parser.t (** Epsilon, i.e. a subexpression that matches an empty input sequence. *) val nil: x (** Use [create r] to compose a lexical analyzer from the rule [r]. *) val create: 'a r -> 'a t (** The module type containing the subexpression composition operators. This module type is included in the signatures of the [Op] and [X.Op] modules. *) module type Expr_Op_T = sig (** Alternating composition. Use [a $| b] to compose an expression that matches either expression [a] or expression [b]. *) val ( $| ): x -> x -> x (** Serial composition. Use [a $& b] to compose an expression that matches expression [a] followed by expression [b]. *) val ( $& ): x -> x -> x (** Star composition. Use [!*a] to compose an expression that matches zero or any number of instances of [a]. *) val ( !* ): x -> x (** Plus composition. Use [!+a] to compose an expression that matches one or more instances of [a]. *) val ( !+ ): x -> x (** Optional composition. Use [!?a] to compose an expression that matches zero or one instance of [a]. *) val ( !? ): x -> x (** Character literal. Use [!:c] to compose an expression that matches the character [c]. *) val ( !: ): char -> x (** Character set. Use [!^f] to compose an expression that matches any character for which the satisfier function [f] returns [true]. *) val ( !^ ): (char -> bool) -> x (** Regular expression sequence. Use [!~z] to parse the sequence [z] according to the grammar defined in {!Cf_regex} module and compose an expression that matches input accordingly. Raises {!Cf_regex.Error} if the sequence is not a regular expression. *) val ( !~ ): char Cf_seq.t -> x (** Regular expression string. Use [!~s] to parse the string [s] according to the grammar defined in {!Cf_regex} module and compose an expression that matches input accordingly. Raises {!Cf_regex.Error} if the string is not a regular expression. *) val ( !$ ): string -> x end (** Open this module to bring the operator functions for simple parsers into the current scope. *) module Op: sig (** Include the expression operators common among lexical analyzers. *) include Expr_Op_T (** Literal token rule. Use [e $= obj] to compose a rule that outputs the literal object [obj] when the expression [e] is recognized. *) val ( $= ): x -> 'a -> 'a r (** String token rule. Use [e $> f] to compose a rule that applies the string recognized by the expression [e] to the tokenizer function [f] to produce its result. *) val ( $> ): x -> (string -> 'a) -> 'a r (** Advanced token rule. Use [e $@ f] to compose a rule that applies the length of the character sequence recognized by the expression [e] to the advanced tokenizer function [f] to obtain a parser that produces the output of the rule and makes any other manipulations necessary to continue parsing the input stream. If the parser returned by [f] does not recognize the input, then no output is produced and no other rules are matched. *) val ( $@ ): x -> (int -> 'a t) -> 'a r (** Rule aggregation. Use this operator to combine a list of rules into a single rule. *) val ( !@ ): 'a r list -> 'a r (** String parser. Use [?~x] to create a simple parser that recognizes any string that matches the expression [x]. {b Note:} Care should be taken when composing parsers with this operator to keep the lazy DFA from being recreated in every pass. *) val ( ?~ ): x -> string t (** String parser. Use [?$s] to create a simple parser that recognizes any string that matches the regular expression specified in the string [s] according to the grammar in the {!Cf_regex} module. Raises {!Cf_regex.Error} if the string is not a regular expression. {b Note:} Care should be taken when composing parsers with this operator to keep from parsing the argument string in every pass. *) val ( ?$ ): string -> string t end (** A module of parser extensions for working with input sequences that require position information to woven into the parse function. *) module X: sig (** The type of lexical analysis rules. *) type ('c, 'a) r constraint 'c = char #Cf_parser.cursor (** Woven character stream parser. *) type ('c, 'a) t = ('c, char, 'a) Cf_parser.X.t constraint 'c = char #Cf_parser.cursor (** Use [create r] to compose a lexical analyzer from the rule [r]. *) val create: ('c, 'a) r -> ('c, 'a) t (** Open this module to bring the operator functions for woven parsers into the current scope. *) module Op: sig (** Include the expression operators common among lexical analyzers. *) include Expr_Op_T (** Literal token rule. Use [e $= obj] to compose a rule that outputs the literal object [obj] when the expression [e] is recognized. *) val ( $= ): x -> 'a -> ('c, 'a) r (** String token rule. Use [e $> f] to compose a rule that applies the string recognized by the expression [e] to the tokenizer function [f] to produce its result. *) val ( $> ): x -> (string -> 'a) -> ('c, 'a) r (** Advanced token rule. Use [e $@ f] to compose a rule that applies the length of the character sequence recognized by the expression [e] to the advanced tokenizer function [f] to obtain a parser that produces the output of the rule and makes any other manipulations necessary to continue parsing the input stream. If the parser returned by [f] does not recognize the input, then no output is produced and no other rules are matched. *) val ( $@ ): x -> (int -> ('c, 'a) t) -> ('c, 'a) r (** Rule aggregation. Use this operator to combine a list of rules into a single rule. *) val ( !@ ): ('c, 'a) r list -> ('c, 'a) r (** String parser. Use [?~x] to create a simple parser that recognizes any string that matches the expression [x]. {b Note:} Care should be taken when composing parsers with this operator to keep the lazy DFA from being recreated in every pass. *) val ( ?~ ): x -> ('c, string) t (** String parser. Use [?$s] to create a simple parser that recognizes any string that matches the regular expression specified in the string [s] according to the grammar in the {!Cf_regex} module. Raises {!Cf_regex.Error} if the string is not a regular expression. {b Note:} Care should be taken when composing parsers with this operator to keep from parsing the argument string in every pass. *) val ( ?$ ): string -> ('c, string) t end end (** A record used by the [cursor] class defined below that indicates the character index, row and column in the input stream associated with a cursor position. *) type counter = { c_pos: int; (** The character index (counts from zero). *) c_row: int; (** The column number (counts from zero). *) c_col: int; (** The row number (counts from zero). *) } (** The initial value of a cursor position counter. *) val counter_zero: counter (** A class derived from {!Cf_parser.cursor} that intercepts newline characters to track the row and column of a cursor position. Use [new cursor ~c s] to construct an initial cursor position, optionally with the counter [c] (default: [counter_zero]), and a string [s] containing the character sequence that is recognized as a newline, e.g. "\013\010" indicates that newline is a CR LF sequence. *) class cursor: ?c:counter -> string -> object inherit [char] Cf_parser.cursor val row_: int (** The current row number *) val col_: int (** The current column number *) val nl0_: char list (** The newline sequence as a [char list]. *) val nlz_: char list (** The current tail of the newline. *) (** [self#next c] is called in the [advance] method to return a new values for the [row_], [col_] and [nlz_] members. *) method private next: char -> int * int * char list (** Returns a new counter object containing the row, column and index of the current cursor position. *) method counter: counter (** Returns the [row_] member. *) method row: int (** Returns the [col_] member. *) method col: int end (*--- End of File [ cf_lex.mli ] ---*) cf-0.10/cf_lexer.ml0000644000175000017500000000717410247271230014046 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_lexer.ml Copyright (c) 2002-2005, 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. *---------------------------------------------------------------------------*) (* module J = Cf_journal let jout = J.stdout *) module Symbol = struct type t = char and 'a map = 'a array let map f = Array.init 256 (fun n -> f (char_of_int n)) let get m c = Array.unsafe_get m (int_of_char c) end module DFA = Cf_dfa.Create(Symbol) class cursor pos = object(_:'self) inherit [char] Cf_parser.cursor pos method error (_: int) (_: (char * 'self) Cf_seq.t) = () end type expr_t = DFA.x type ('c, 'x) rule_t = ('c, 'x) DFA.X.r constraint 'c = #cursor type ('c, 'x) t = ('c, 'x) DFA.X.t constraint 'c = #cursor module Op = struct include DFA.X.Op let ( !$ ) str = !~ (Cf_seq.of_string str) let ( $^ ) e f = e $> (fun z -> f (Cf_seq.to_string z)) end open DFA.Op let nil = DFA.nil let create dfa = DFA.X.create dfa type counter_t = { c_pos: int; c_row: int; c_col: int; } let counter_zero = { c_pos = 0; c_row = 0; c_col = 0; } class line_cursor ?(c = counter_zero) newline = let nl0 = Cf_seq.to_list (Cf_seq.of_string newline) in object(self:'self) inherit cursor c.c_pos val row_: int = c.c_row val col_: int = c.c_col val nlz_: char list = nl0 val nl0_: char list = nl0 method counter = { c_pos = position_; c_row = row_; c_col = col_; } method row = row_ method col = col_ method private next ch = match nlz_ with | hd :: [] when ch = hd -> succ row_, 0, nl0_ | hd :: tl when ch = hd -> row_, succ col_, tl | _ -> row_, succ col_, nlz_ method advance ch = let row, col, nlz = self#next ch in {< position_ = succ position_; row_ = row; col_ = col; nlz_ = nlz_ >} end exception Error of counter_t let raise_exn n s = Error begin match Lazy.force (Cf_seq.shift n s) with | Cf_seq.Z -> assert (not true); counter_zero | Cf_seq.P ((_, cursor), _) -> cursor#counter end (*--- End of File [ cf_lexer.ml ] ---*) cf-0.10/cf_lexer.mli0000644000175000017500000002050010247271230014203 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_lexer.mli Copyright (c) 2002-2005, 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 of regular grammars. *) (** {6 Overview} This module implements functional parsers of the type defined in the {!Cf_parser.X} module using lazy deterministic finite automata. Ordinary characters are the symbol type. {b Note}: functions for converting regular expression strings into lexer 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 = #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 = #cursor (** {6 Functions} *) (** 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 ( !: ): char -> expr_t (** Use [!^f] to compose an expression that matches any character for which the satisfier function [f] returns [true]. *) val ( !^ ): (char -> bool) -> expr_t (** Use [!~z] to compose an expression that matches the sequence of characters [z]. *) val ( !~ ): char Cf_seq.t -> expr_t (** Use [!$lit] to compose an expression that matches the string literal [lit]. *) val ( !$ ): string -> expr_t (** Alternating composition. Use [a $| b] to compose an expression that matches either expression [a] or expression [b]. *) val ( $| ): expr_t -> expr_t -> expr_t (** Serial composition. Use [a $& b] to compose an expression that matches expression [a] followed by expression [b]. *) val ( $& ): expr_t -> expr_t -> expr_t (** Star composition. Use [!*a] to compose an expression that matches zero or any number of instances of [a]. *) val ( !* ): expr_t -> expr_t (** Plus composition. Use [!+a] to compose an expression that matches one or more instances of [a]. *) val ( !+ ): expr_t -> expr_t (** Optional composition. Use [!?a] to compose an expression that matches zero or one instance of [a]. *) val ( !? ): expr_t -> expr_t (** Literal token rule. Use [e $= obj] to compose a rule that outputs the literal object [obj] when the expression [e] is recognized. *) val ( $= ): expr_t -> 'x -> ('c, 'x) rule_t (** Character sequence token rule. Use [e $> f] to compose a rule that applies the sequence of character recognized by the expression [e] to the tokenizer function [f] to produce its result. *) val ( $> ): expr_t -> (char Cf_seq.t -> 'x) -> ('c, 'x) rule_t (** String token rule. Use [e $> f] to compose a rule that applies the string recognized by the expression [e] to the tokenizer function [f] to produce its result. *) val ( $^ ): expr_t -> (string -> 'x) -> ('c, 'x) rule_t (** Advanced token rule. Use [e $@ f] to compose a rule that applies the length of the character sequence recognized by the expression [e] to the advanced tokenizer function [f] to obtain a parser that produces the output of the rule and makes any other manipulations necessary to continue parsing the input stream. If the parser returned by [f] does not recognize the input, then no output is produced by the lexer. *) val ( $@ ): expr_t -> (int -> ('c, 'x) t) -> ('c, 'x) rule_t (** Rule aggregation. Use this operator to combine a list of rules into a single rule. *) val ( !@ ): ('c, 'x) rule_t list -> ('c, 'x) rule_t end (** The lexer expression that recognizes the empty input sequence, i.e. epsilon. *) val nil: expr_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 cursor position. *) type counter_t = { c_pos: int; (** The character index (counts from zero). *) c_row: int; (** The column number (counts from zero). *) c_col: int; (** The row number (counts from zero). *) } (** The initial value of a cursor position counter. *) val counter_zero: counter_t (** A class derived from {!Cf_parser.cursor} that intercepts newline characters to track the row and column of a cursor position. Use [new line_cursor ~c s] to construct an initial cursor position, optionally with the counter [c] (default: [counter_zero]), and a string [s] containing the character sequence that is recognized as a newline, e.g. "\013\010" indicates that newline is a CR LF sequence. *) class line_cursor: ?c:counter_t -> string -> object inherit cursor val row_: int (** The current row number *) val col_: int (** The current column number *) val nl0_: char list (** The newline sequence as a [char list]. *) val nlz_: char list (** The current tail of the newline. *) (** [self#next c] is called in the [advance] method to return a new values for the [row_], [col_] and [nlz_] members. *) method private next: char -> int * int * char list (** Returns a new counter object containing the row, column and index of the current cursor position. *) method counter: counter_t (** Returns the [row_] member. *) method row: int (** Returns the [col_] member. *) method col: int end (** The exception raised by the [raise_exn] exception handler function below. *) exception Error of counter_t (** An optional exception handler function for use in streams woven with 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: int -> (char * #line_cursor) Cf_seq.t -> exn (*--- End of File [ cf_lexer.mli ] ---*) cf-0.10/cf_machine.ml0000644000175000017500000000427310433520572014333 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_machine.ml Copyright (c) 2005-2006, 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. *---------------------------------------------------------------------------*) open Cf_cmonad.Op class virtual ['i, 'o] start = object(self:'self) method private virtual guard: ('self, 'i, 'o, unit) Cf_state_gadget.guard method start: 's. ('s, 'i, 'o, unit) Cf_state_gadget.t = Cf_state_gadget.start (Cf_state_gadget.guard self#guard) self end class virtual ['i, 'o] next = object(self:'self) method private virtual guard: ('self, 'i, 'o, unit) Cf_state_gadget.guard method next: 'a. ('self, 'i, 'o, 'a) Cf_state_gadget.t = Cf_state_gadget.store self >>= fun () -> Cf_state_gadget.guard self#guard end (*--- End of File [ cf_machine.ml ] ---*) cf-0.10/cf_machine.mli0000644000175000017500000000605310433520572014502 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_machine.mli Copyright (c) 2005-2006, 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. *---------------------------------------------------------------------------*) (** Object-oriented framework for monadic composition of complex stream processors. *) (** {6 Overview} This module extends {!Cf_state_gadget} with an object-oriented framework. The idea is to facilitate reuse of gadget monads among related processes by class inheritance. *) (** Use [inherit \['i, 'o\] start] to derive a class to represent the initial state of a machine. It's [start] method initiates the machine with the virtual private [guard] method. *) class virtual ['i, 'o] start: object('self) (** The first guard evaluationed by the machine after starting. *) method virtual private guard: ('self, 'i, 'o, unit) Cf_state_gadget.guard (** Starts a new gadget process. Defined as {!Cf_state_gadget.start} [Cf_state_gadget.guard self#guard self]. *) method start: 's. ('s, 'i, 'o, unit) Cf_state_gadget.t end (** Use [inherit \['i, 'o\] next] to derive a class that implements an intermediate state in a machine. *) class virtual ['i, 'o] next: object('self) (** The guard evaluated by this state of the machine. *) method virtual private guard: ('self, 'i, 'o, unit) Cf_state_gadget.guard (** Use [obj#next] to transition the state of the machine by storing [obj] in the state of the gadget and applying {!Cf_state_gadget.guard} [self#guard]. *) method next: 'a. ('self, 'i, 'o, 'a) Cf_state_gadget.t end (*--- End of File [ cf_machine.mli ] ---*) cf-0.10/cf_map.ml0000644000175000017500000000612610433520572013503 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_map.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) module type T = sig type +'a t module Key: sig type t end val nil: 'a t val empty: 'a t -> bool val size: 'a t -> int val min: 'a t -> (Key.t * 'a) val max: 'a t -> (Key.t * 'a) val search: Key.t -> 'a t -> 'a val member: Key.t -> 'a t -> bool val insert: (Key.t * 'a) -> 'a t -> 'a t * 'a option val replace: (Key.t * 'a) -> 'a t -> 'a t val modify: Key.t -> ('a -> 'a) -> 'a t -> 'a t val extract: Key.t -> 'a t -> 'a * 'a t val delete: Key.t -> 'a t -> 'a t val of_list: (Key.t * 'a) list -> 'a t val of_list_incr: (Key.t * 'a) list -> 'a t val of_list_decr: (Key.t * 'a) list -> 'a t val of_seq: (Key.t * 'a) Cf_seq.t -> 'a t val of_seq_incr: (Key.t * 'a) Cf_seq.t -> 'a t val of_seq_decr: (Key.t * 'a) Cf_seq.t -> 'a t val to_list_incr: 'a t -> (Key.t * 'a) list val to_list_decr: 'a t -> (Key.t * 'a) list val to_seq_incr: 'a t -> (Key.t * 'a) Cf_seq.t val to_seq_decr: 'a t -> (Key.t * 'a) Cf_seq.t val nearest_decr: Key.t -> 'a t -> (Key.t * 'a) Cf_seq.t val nearest_incr: Key.t -> 'a t -> (Key.t * 'a) Cf_seq.t val iterate: ((Key.t * 'a) -> unit) -> 'a t -> unit val predicate: ((Key.t * 'a) -> bool) -> 'a t -> bool val fold: ('b -> (Key.t * 'a) -> 'b) -> 'b -> 'a t -> 'b val filter: ((Key.t * 'a) -> bool) -> 'a t -> 'a t val map: ((Key.t * 'a) -> 'b) -> 'a t -> 'b t val optmap: ((Key.t * 'a) -> 'b option) -> 'a t -> 'b t val partition: ((Key.t * 'a) -> bool) -> 'a t -> 'a t * 'a t end (*--- End of File [ cf_map.ml ] ---*) cf-0.10/cf_map.mli0000644000175000017500000002421710433520572013655 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_map.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** A module type for associative array implementations (with functional enhancements over the {!Map} module in the standard library). *) (** {6 Overview} This module defines the common interface to the various implementations of functional associative arrays in the {!Cf} library. *) module type T = sig (** The tree type. *) type +'a t (** A module defining the type of the key. Some map implementations may define more functions in this module for disambiguating keys from one another. *) module Key: sig type t end (** The empty tree. *) val nil: 'a t (** Use [empty m] to test whether the tree [m] is empty. *) val empty: 'a t -> bool (** Use [size m] to count the number of elements in the tree [m]. *) val size: 'a t -> int (** Use [min m] to obtain the key-value pair with the ordinally minimum key in the tree [m]. Raises [Not_found] if the tree is empty. *) val min: 'a t -> (Key.t * 'a) (** Use [max m] to obtain the key-value pair with the ordinally maximum key in the tree [m]. Raises [Not_found] if the tree is empty. *) val max: 'a t -> (Key.t * 'a) (** Use [search k m] to obtain the value associated with the key [k] in the tree [m]. Raise [Not_found] if the tree does not contain the key. *) val search: Key.t -> 'a t -> 'a (** Use [member k m] to test whether the tree [m] contains the key [k]. *) val member: Key.t -> 'a t -> bool (** Use [insert p m] to insert the key-value pair [p] into the tree [m], producing a new tree with the inserted element and, if the key [k] is already present in [m], the value replaced by the insertion. *) val insert: (Key.t * 'a) -> 'a t -> 'a t * 'a option (** Use [replace p m] to obtain a new tree produced by inserting the key-value pair [p] into the tree [m], replacing any existing pair associated to the same key. *) val replace: (Key.t * 'a) -> 'a t -> 'a t (** Use [modify k f m] to obtain a new tree produced by replacing the value in the tree [m] associated with the key [k] with the result of applying it to the continuation function [f]. Raises [Not_found] if the tree does not contain the key. *) val modify: Key.t -> ('a -> 'a) -> 'a t -> 'a t (** Use [extract k m] to obtain the value associated with the key [k] in the tree [m] and a new tree with the key deleted from the tree. Raises [Not_found] if the tree does not contain the key. *) val extract: Key.t -> 'a t -> 'a * 'a t (** Use [delete k m] to obtain a new tree produced by deleting the key [k] from the tree [m]. If the tree does not contain the key, then the function simply returns its argument. *) val delete: Key.t -> 'a t -> 'a t (** Use [of_list s] to compose a tree by iterating the list of key-value pairs [s] and inserting them in order into a new tree. *) val of_list: (Key.t * 'a) list -> 'a t (** Use [of_list_incr s] to compose a tree with the key-value pairs in the ordered list [s]. Runs in linear time if the keys in the list [s] are known to be in increasing order. Otherwise, there is an additional linear cost beyond [of_list s]. *) val of_list_incr: (Key.t * 'a) list -> 'a t (** Use [of_list_decr s] to compose a tree with the key-value pairs in the ordered list [s]. Runs in linear time if the keys in the list [s] are known to be in decreasing order. Otherwise, there is an additional linear cost beyond [of_list s]. *) val of_list_decr: (Key.t * 'a) list -> 'a t (** Use [of_seq z] to compose a tree by evaluating the entire sequence of key-value pairs [z] and inserting them in order into a new tree. *) val of_seq: (Key.t * 'a) Cf_seq.t -> 'a t (** Use [of_seq_incr z] to compose a tree with the key-value pairs in the ordered sequence [z]. Runs in linear time if the keys in the sequence [z] are known to be in increasing order. Otherwise, there is an additional linear cost beyond [of_seq z]. *) val of_seq_incr: (Key.t * 'a) Cf_seq.t -> 'a t (** Use [of_seq_decr z] to compose a tree with the key-value pairs in the ordered sequence [z]. Runs in linear time if the keys in the sequence [z] are known to be in decreasing order. Otherwise, there is an additional linear cost beyond [of_seq z]. *) val of_seq_decr: (Key.t * 'a) Cf_seq.t -> 'a t (** Use [to_list_incr m] to obtain a sequence of the key-value pairs in the tree [m] in order of increasing ordinality. *) val to_list_incr: 'a t -> (Key.t * 'a) list (** Use [to_list_decr m] to obtain a sequence of the key-value pairs in the tree [m] in order of descreasing ordinality. *) val to_list_decr: 'a t -> (Key.t * 'a) list (** Use [to_seq_incr m] to obtain a sequence of the key-value pairs in the tree [m] in order of increasing ordinality. *) val to_seq_incr: 'a t -> (Key.t * 'a) Cf_seq.t (** Use [to_seq_decr m] to obtain a sequence of the key-value pairs in the tree [m] in order of descreasing ordinality. *) val to_seq_decr: 'a t -> (Key.t * 'a) Cf_seq.t (** Use [nearest_decr k m] to obtain the key-value pair ordinally less than or equal to the key [k] in the map [m]. Raises [Not_found] if the map is empty or all the keys are ordinally greater. *) val nearest_decr: Key.t -> 'a t -> (Key.t * 'a) Cf_seq.t (** Use [nearest_incr k m] to obtain the key-value pair ordinally greater than or equal to the key [k] in the map [m]. Raises [Not_found] if the map is empty or all the keys are ordinally less. *) val nearest_incr: Key.t -> 'a t -> (Key.t * 'a) Cf_seq.t (** Use [iterate f m] to apply the function [f] to each key-value pair in the tree [m] in an arbitrary order (not increasing or decreasing). *) val iterate: ((Key.t * 'a) -> unit) -> 'a t -> unit (** Use [predicate f m] to test whether all the key-value pairs in the tree [m] satisfy the predicate function [f]. The nodes of the tree are visited in an arbitrary order (not increasing or decreasing). *) val predicate: ((Key.t * 'a) -> bool) -> 'a t -> bool (** Use [fold f s m] to fold the every key-value pair in the tree [m] into the state [s] with the folding function [f], visiting the elements in an arbitrary order (not increasing or decreasing). Runs in O(log N) space, i.e. not tail-recursive. *) val fold: ('b -> (Key.t * 'a) -> 'b) -> 'b -> 'a t -> 'b (** Use [filter f m] to obtain a new tree comprised of all the key-value pairs in the tree [m] that satisfy the filtering function [f]. The elements in [m] are visited in arbitrary order (not increasing or decreasing). Runs in O(log N) space, i.e. not tail-recursive. *) val filter: ((Key.t * 'a) -> bool) -> 'a t -> 'a t (** Use [map f m] to obtain a new tree produced by applying the mapping function [f] to the key and the value of each key-value pair in the tree [m] and associating the resulting value to the key in the new tree. Elements in the tree are visited in arbitrary order (not increasing or descreasing. Runs in O(log N) space, i.e. not tail-recursive. *) val map: ((Key.t * 'a) -> 'b) -> 'a t -> 'b t (** Use [optmap f m] to obtain a new tree produced by applying the mapping function [f] to the key and the value of each key-value pair in the tree [m] and associating the resulting value to the key in the new tree. If the function [f] returns [None] then no value for that key will be present in the new tree. Elements in the tree are visited in arbitrary order (not increasing or descreasing. Runs in O(log N) space, i.e. not tail-recursive. *) val optmap: ((Key.t * 'a) -> 'b option) -> 'a t -> 'b t (** Use [partition f m] to obtain a pair of new trees produced by applying the partitioning function [f] to all the elements in the tree [m] in an arbitrary order (not increasing or descreasing). The first tree will contain all the elements for which [f] returns [true], and the second tree will have all the elements for which [f] returns [false]. Runs in O(log N) space, i.e. not tail-recursive. *) val partition: ((Key.t * 'a) -> bool) -> 'a t -> 'a t * 'a t end (*--- End of File [ cf_map.mli ] ---*) cf-0.10/cf_message.ml0000644000175000017500000001663710450664611014364 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_message.ml Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) type substring = string * int * int and t = substring list let sub_invariant_ (s, pos, len) = let size = String.length s in pos >= 0 && pos < size && len > 0 && pos + len <= size let rec test_invariant_ = function | [] -> true | hd :: tl -> if sub_invariant_ hd then test_invariant_ tl else false let rec filter_for_invariant_ acc = function | [] -> List.rev acc | hd :: tl -> filter_for_invariant_ (if sub_invariant_ hd then hd :: acc else acc) tl let normalize m = if test_invariant_ m then m else filter_for_invariant_ [] m let rec sub_blit_loop_ ?(i = 0) dest = function | [] -> () | (s, pos, len) :: tl -> assert (sub_invariant_ (dest, i, len)); String.blit s pos dest i len; let i = i + len in sub_blit_loop_ ~i dest tl let create s = let n = String.length s in if n > 0 then [ s, 0, n ] else [] let length = let f acc (_, _, len as sub) = assert (sub_invariant_ sub); acc + len in List.fold_left f 0 let contents = function | [] -> "" | tl -> let n = length tl in let s = String.create n in sub_blit_loop_ s tl; s let copy m = create (contents m) let flatten = function | _ :: _ :: _ as m -> copy m | m -> m let x_pos_negative_ = "pos < 0" let x_pos_range_ = "pos > length" let rec split_aux_ (i, l1, l2) = function | [] -> if i > 0 then invalid_arg x_pos_range_; List.rev l1, List.rev l2 | hd :: tl -> assert (sub_invariant_ hd); let acc = let s, pos, len = hd in match i with | 0 -> 0, l1, hd :: l2 | _ when i < len -> 0, (s, pos, i) :: l1, (s, pos + i, len - i) :: l2 | _ -> i - len, hd :: l1, [] in split_aux_ acc tl let split ~pos = match pos with | pos when pos < 0 -> invalid_arg x_pos_negative_ | pos when pos > 0 -> split_aux_ (pos, [], []) | _ -> (fun m -> [], m) let rec truncate_aux_ l0 i = function | [] -> if i > 0 then invalid_arg x_pos_range_; List.rev l0 | hd :: tl -> assert (sub_invariant_ hd); let s, pos, len = hd in match i with | 0 -> List.rev l0 | _ when i < len -> List.rev ((s, pos, i) :: l0) | _ -> truncate_aux_ (hd :: l0) (i - len) tl let truncate ~pos = match pos with | pos when pos < 0 -> invalid_arg x_pos_negative_ | pos when pos > 0 -> truncate_aux_ [] pos | _ -> (fun _ -> []) let rec shift_aux_ i = function | [] -> if i > 0 then invalid_arg x_pos_range_; [] | hd :: tl -> assert (sub_invariant_ hd); let s, pos, len = hd in if i < len then (s, pos + i, len - i) :: tl else shift_aux_ (i - len) tl let shift ~pos = match pos with | 0 -> (fun x -> x) | pos when pos < 0 -> invalid_arg x_pos_negative_ | pos -> shift_aux_ pos let rec insert_aux_ l0 l1 i = function | [] -> if i > 0 then invalid_arg x_pos_range_; List.rev_append l0 l1 | hd :: tl -> assert (sub_invariant_ hd); let s, pos, len = hd in if i = 0 then begin assert (not true); [] end else if i < len then begin let sub1 = s, pos, i and sub2 = s, pos + i, len - i in let l0 = sub1 :: l0 and tl = sub2 :: tl in insert_aux_ l0 (l1 @ tl) 0 [] end else insert_aux_ (hd :: l0) l1 (i - len) tl let insert ~pos = match pos with | 0 -> (fun ~m m0 -> m @ m0) | pos when pos < 0 -> invalid_arg x_pos_negative_ | pos -> (fun ~m -> insert_aux_ [] m pos) let push m q = List.fold_left begin fun q s -> if sub_invariant_ s then Cf_deque.A.push s q else q end q m let unsafe_push m q = List.fold_left (fun q s -> Cf_deque.A.push s q) q m let drain q = Cf_deque.B.to_list q let drain_seq ?x = let rec aux (buf, pos, len) = Cf_seq.limit ?x len (Cf_seq.of_substring buf pos) in fun q -> Cf_seq.flatten (Cf_seq.map aux (Cf_deque.B.to_seq q)) let rec pop_aux_ m x q = if x > 0 then match Cf_deque.B.pop q with | Some ((buf, pos, len), tl) when len > x -> let hd1 = buf, pos + x, len - x and hd0 = buf, pos, x in pop_aux_ (hd0 :: m) 0 (Cf_deque.B.push hd1 tl) | Some ((_, _, len as hd), tl) -> pop_aux_ (hd :: m) (x - len) tl | None -> List.rev m, q else List.rev m, q let pop ~len q = pop_aux_ [] len q let rec shiftq_aux_ x q = if x > 0 then match Cf_deque.B.pop q with | Some ((buf, pos, len), tl) when len > x -> let hd1 = buf, pos + x, len - x in shiftq_aux_ 0 (Cf_deque.B.push hd1 tl) | Some ((_, _, len), tl) -> shiftq_aux_ (x - len) tl | None -> q else q let shiftq ~len q = shiftq_aux_ len q let rec unsafe_shift1 = function | (buf, pos, len) :: tl when len > 1 -> (buf, pos + 1, len - 1) :: tl | _ :: tl -> tl | [] -> [] let rec unsafe_to_seq ?x m = lazy begin match m with | (buf, pos, _) :: _ as m -> let hd = String.unsafe_get buf pos in let tl = unsafe_to_seq ?x (unsafe_shift1 m) in Cf_seq.P (hd, tl) | [] -> match x with None -> Cf_seq.Z | Some x -> raise x end let unsafe_to_function ?x m = let r = ref m in let rec loop () = match !r with | [] -> raise (match x with None -> End_of_file | Some x -> x) | (buf, pos, _) :: _ as m -> r := unsafe_shift1 m; String.unsafe_get buf pos in loop let to_seq ?x m = unsafe_to_seq ?x (normalize m) let to_function ?x m = unsafe_to_function ?x (normalize m) (*--- End of File [ cf_message.ml ] ---*) cf-0.10/cf_message.mli0000644000175000017500000001602010450664611014517 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_message.mli Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) (** Functional message buffer chains. *) (** {6 Overview} This module implements convenience functions useful when manipulating lists of substrings that represent portable inter-process communication messages. A list of substrings is very much like the "mbuf" chain commonly found in network protocol stacks, and this module facilitates composing and manipulating messages in this way. *) (** {6 Types} *) (** The type of messages, i.e. a list of substrings (a string, the position of the first character in the substring, and the length of the substring). *) type substring = string * int * int and t = substring list (** {6 Functions} *) (** Use [normalize m] to discard empty substrings from the list. Raises [Invalid_arg] if any of the substrings have a negative length or which specify invalid substrings of the string component of the triple. *) val normalize: t -> t (** Use [create s] to obtain a new message composed of a flattened message containing the string [s]. Returns the empty list when the string is the empty string. *) val create: string -> t (** Use [length m] to compute the length of the message [m]. *) val length: t -> int (** Use [contents m] to create a new string containing the entire text of the message [m]. *) val contents: t -> string (** Use [copy m] to create a new message with a deep copy of the contents of [m], i.e. it is equivalent to [create (contents m)]. *) val copy: t -> t (** Use [flatten m] to reduce a message list of two or more substrings to a single substring. If [m] is already a single substring or the empty list, then [m] itself is returned. Otherwise, the result is the same as what [copy m] would return. *) val flatten: t -> t (** Use [split ~pos m] to return two new messages, the first containing all the text in message [m] before the position [pos], and the second containing all the remaining text in message [m]. The strings themselves are not copied; only the list of substrings is manipulated. Raises [Invalid_argument] if the position is negative or beyond the length of the message. *) val split: pos:int -> t -> t * t (** Use [truncate ~pos m] to return a new message containing all the text in message [m] before the position [pos]. The strings themselves are not copied; only the list of substrings is manipulated. Raises [Invalid_argument] if the position is negative or beyond the length of the message. *) val truncate: pos:int -> t -> t (** Use [shift ~pos m] to return a new message with all the text in message [m] before the position [pos] removed. This strings themselves are not copied; only the list of substrings is manipulated. Raises [Invalid_argument] if the position is negative or beyond the length of the message. *) val shift: pos:int -> t -> t (** Use [insert ~pos ~m m1] to return a new message with all the text in message [m] inserted into the message [m1] at the position [pos]. The strings themselves are not copied; only the list of substrings is manipulated. Raises [Invalid_argument] if the position is negative or beyond the length of the message. *) val insert: pos:int -> m:t -> t -> t (** Use [push m q] to push the message [m] into the [A] end of the substring queue [q]. *) val push: t -> substring Cf_deque.t -> substring Cf_deque.t (** Use [pop ~len q] to pop a message of length no larger than [len] from the [B] end of the substring deque [q]. The message and the remainder of the deque are returned. *) val pop: len:int -> substring Cf_deque.t -> t * substring Cf_deque.t (** Use [shiftq ~len q] to discard the first [len] octets from the [B] end of the substring deque [q]. The remainder of the deque is returned. *) val shiftq: len:int -> substring Cf_deque.t -> substring Cf_deque.t (** Use [drain q] to convert the entire substring deque [q] into a message. *) val drain: substring Cf_deque.t -> t (** Use [drain_seq q] to convert the substring deque [q] into a character sequence. If [?x] is provided then evaluating the sequence past the last character in the message raises the exception. (This is more efficient than applying [Cf_seq.sentinel] to the result.) *) val drain_seq: ?x:exn -> substring Cf_deque.t -> char Cf_seq.t (** Use [to_seq m] to obtain the sequence of characters in message [m]. The message is immediately normalized with [normalize m]. If [?x] is provided then evaluating the sequence past the last character in the message raises the exception. (This is more efficient than applying [Cf_seq.sentinel] to the result.) *) val to_seq: ?x:exn -> t -> char Cf_seq.t (** [to_function m] returns a function that returns successive characters from the message [m] each time it is called, until it raises [x] when there are no more characters. If [x] is not provided, then [End_of_file] is raised. *) val to_function: ?x:exn -> t -> (unit -> char) (**/**) (** The same as [push m q] except the message is assumed to be normalized already. *) val unsafe_push: t -> substring Cf_deque.t -> substring Cf_deque.t (** Shifts one character off the start of the text of the message. Assumes the message is normalized. *) val unsafe_shift1: t -> t (** The same as [to_seq ?x m] except the message is assumed to be normalized already. *) val unsafe_to_seq: ?x: exn -> t -> char Cf_seq.t (** The same as [to_function ?x m] except the message is assumed to be normalized already. *) val unsafe_to_function: ?x:exn -> t -> (unit -> char) (*--- End of File [ cf_message.mli ] ---*) cf-0.10/cf_nameinfo.ml0000644000175000017500000001133010433520572014513 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_nameinfo.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) type unresolved = EAI_ADDRFAMILY | EAI_AGAIN | EAI_BADFLAGS | EAI_FAIL | EAI_FAMILY | EAI_MEMORY | EAI_NODATA | EAI_NONAME | EAI_SERVICE | EAI_SOCKTYPE | EAI_BADHINTS | EAI_PROTOCOL | EAI_UNKNOWN of int exception Unresolved of unresolved let _ = Callback.register_exception "Cf_nameinfo.Unresolved" (Unresolved (EAI_UNKNOWN (-1))) external error_message: unresolved -> string = "cf_nameinfo_error_message" ;; external init_: unit -> unit = "cf_nameinfo_init";; init_ ();; external domain_: unit -> unit Cf_socket.domain = "cf_nameinfo_domain" external socktype_: unit -> unit Cf_socket.socktype = "cf_nameinfo_socktype" external protocol_: unit -> Cf_socket.protocol = "cf_nameinfo_protocol" external unspecified_: unit -> unit Cf_socket.sockaddr = "cf_nameinfo_unspecified" module P = struct module ST = struct type tag = unit let socktype = socktype_ () end module AF = struct type tag = unit type address = unit Cf_socket.sockaddr let domain = domain_ () let to_sockaddr = Obj.magic let of_sockaddr = Obj.magic let unspecified = unspecified_ () end let protocol = protocol_ () end external is_specific_socktype: unit Cf_socket.socktype -> 'st Cf_socket.socktype -> bool = "cf_nameinfo_is_specific_socktype" external is_specific_domain: unit Cf_socket.sockaddr -> 'af Cf_socket.domain -> bool = "cf_nameinfo_is_specific_domain" external specialize_sockaddr: unit Cf_socket.sockaddr -> 'af Cf_socket.domain -> 'af Cf_socket.sockaddr = "cf_nameinfo_specialize_sockaddr" type of_address_flags = { ni_nofqdn: bool; ni_numerichost: bool; ni_namereqd: bool; ni_numericserv: bool; ni_dgram: bool; } let of_address_default_flags = { ni_nofqdn = false; ni_numerichost = false; ni_namereqd = false; ni_numericserv = false; ni_dgram = false; } external of_address: ?host:int -> ?serv:int -> ?flags:of_address_flags -> 'a Cf_socket.sockaddr -> string * string = "cf_nameinfo_of_address" type to_address_flags = { ai_passive: bool; ai_canonname: bool; ai_numerichost: bool; } external default_ai_flags_: unit -> to_address_flags = "cf_nameinfo_default_ai_flags" let to_address_default_flags = default_ai_flags_ () type to_address_arg = | A_nodename of string | A_servicename of string | A_bothnames of string * string type ('af, 'st) addrinfo = { ai_flags: to_address_flags; ai_family: 'af Cf_socket.domain; ai_socktype: 'st Cf_socket.socktype; ai_protocol: Cf_socket.protocol; ai_cname: string option; ai_addr: 'af Cf_socket.sockaddr; } let nzero_ = Nativeint.of_int 0 let addrinfo_hint ?(flags = to_address_default_flags) af st p = { ai_flags = flags; ai_family = af; ai_socktype = st; ai_protocol = p; ai_cname = None; ai_addr = Obj.magic P.AF.unspecified; } let addrinfo_default_hint = addrinfo_hint P.AF.domain P.ST.socktype P.protocol external to_addresses: ('af, 'st) addrinfo -> to_address_arg -> ('af, 'st) addrinfo list = "cf_nameinfo_to_addresses" let to_all_addresses arg = to_addresses addrinfo_default_hint arg (*--- End of File [ cf_nameinfo.ml ] ---*) cf-0.10/cf_nameinfo.mli0000644000175000017500000001726110433520572014675 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_nameinfo.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** Domain name resolver interface. *) (** {6 Overview} This module is a wrapper over the C interface to the Domain Name Resolver for IPv6 hosts. These functions typically block until network resources respond to remote queries, sometimes within a few milliseconds. Some exceptions are associated with conditions that take several seconds to detect, e.g. no domain name service available. Two functions are defined: [to_address] and [of_address]. Each function takes an optional argument in the form of a record of boolean flags to control the parameters of the query, much in the way the C interface to the [getaddrinfo()] and [getnameinfo()] functions work. Exceptions raised by the [to_address] and [of_address] functions are all of variants of type [unresolved] constructed on the exception [Unresolved] defined below. *) (** The sum type of exception conditions *) type unresolved = | EAI_ADDRFAMILY (** Address family not supported for node. *) | EAI_AGAIN (** Temporary failure in name resolution. *) | EAI_BADFLAGS (** Invalid value for flags. *) | EAI_FAIL (** Non-recoverable failure in name resolution. *) | EAI_FAMILY (** Address family not supported by resolver. *) | EAI_MEMORY (** Memory allocation failure. *) | EAI_NODATA (** No address associated with name. *) | EAI_NONAME (** No name associated with address. *) | EAI_SERVICE (** Service name not supported for socket type. *) | EAI_SOCKTYPE (** Socket type not supported. *) | EAI_BADHINTS (** Bad hints in getaddrinfo(). *) | EAI_PROTOCOL (** Protocol not supported. *) | EAI_UNKNOWN of int (** Unknown error code. *) (** The exception type. *) exception Unresolved of unresolved (** The unspecified socket protocol, used in composing hints. *) module P: Cf_socket.P with type AF.tag = unit and type ST.tag = unit (** Returns true if the socket types are equivalent. *) val is_specific_socktype: unit Cf_socket.socktype -> 'st Cf_socket.socktype -> bool (** Returns true if the socket address is of the specific domain. *) val is_specific_domain: unit Cf_socket.sockaddr -> 'af Cf_socket.domain -> bool (** Use [specialize_sockaddr sa d] to specialize a socket address [sa] from the unspecified (or unknown) address family into a socket address of the address family associated with the socket domain [d]. Raises [Not_found] if the socket address is not of the appropriate address family. *) val specialize_sockaddr: unit Cf_socket.sockaddr -> 'af Cf_socket.domain -> 'af Cf_socket.sockaddr (** The type of flags used with the [of_address] function to control the parameters of queries for host and service names. *) type of_address_flags = { ni_nofqdn: bool; (** Return only the nodename for local hosts. *) ni_numerichost: bool; (** Return only the numeric form (no DNS query). *) ni_namereqd: bool; (** Raise exception unless name in DNS. *) ni_numericserv: bool; (** Return only the numeric form (no DNS query). *) ni_dgram: bool; (** Use "udp" in getservbyname(). *) } (** The default value of flags for the [of_address] function below (all flags set to [false]). *) val of_address_default_flags: of_address_flags (** Use [of_address ?host ?serv ?flags sa] to resolve the name of the host and the service associated with the socket address [sa]. If the [?host] or [?serv] parameters are provided, they are used as the maximum length of the returned host and/or service name, respectively. Returns an pair of strings, the first is the host name and the second is the service name. Raises [Unix.Error] if there is an error. *) val of_address: ?host:int -> ?serv:int -> ?flags:of_address_flags -> 'a Cf_socket.sockaddr -> string * string (** The type of flags used with the [to_address] function to control the parameters of queries for host addresses and service numbers. *) type to_address_flags = { ai_passive: bool; (** Return a socket address for a listener. *) ai_canonname: bool; (** Return the canonical name. *) ai_numerichost: bool; (** Require numeric input (no DNS query). *) } (** The default value of [ai_flags] record field for the hints provided to the [to_address] function below (all flags set to [false]). *) val to_address_default_flags: to_address_flags (** The argument to the [to_address] function. *) type to_address_arg = | A_nodename of string (** Unspecified service name. *) | A_servicename of string (** Unspecified host name. *) | A_bothnames of string * string (** Host and service names. *) (** The type of elements in the list returned by the [to_address] function. *) type ('af, 'st) addrinfo = private { ai_flags: to_address_flags; (** Query control in hints. *) ai_family: 'af Cf_socket.domain; (** The socket address family. *) ai_socktype: 'st Cf_socket.socktype; (** The socket type. *) ai_protocol: Cf_socket.protocol; (** The socket protocol. *) ai_cname: string option; (** The canonical name. *) ai_addr: 'af Cf_socket.sockaddr; (** The address. *) } (** Construct a hints value for the [to_address] function. *) val addrinfo_hint: ?flags:to_address_flags -> 'af Cf_socket.domain -> 'st Cf_socket.socktype -> Cf_socket.protocol -> ('af, 'st) addrinfo (** The default hints value for the [to_address] function, . *) val addrinfo_default_hint: (unit, unit) addrinfo (** Use [to_addresses hint arg] to obtain a list of address information records associated with the host name and/or service name provided in the argument [arg], using the hints provided in the [hint] argument. *) val to_addresses: ('af, 'st) addrinfo -> to_address_arg -> ('af, 'st) addrinfo list (** Use [to_all_address arg] to obtain a list of address information records associated with the host name and/or service name provided in the argument [arg]. The default hints are used. *) val to_all_addresses: to_address_arg -> (unit, unit) addrinfo list (*--- End of File [ cf_nameinfo.mli ] ---*) cf-0.10/cf_nameinfo_p.c0000644000175000017500000004725510674120413014660 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_nameinfo_p.c Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_nameinfo_p.h" #include #include #include #include #include #include #include #include #include #define INVALID_ARGUMENT(S) (invalid_argument("Cf_nameinfo." S)) #define FAILWITH(S) (failwith("Cf_nameinfo." S)) static int cf_nameinfo_sockaddr_compare(value v1, value v2) { CAMLparam2(v1, v2); const Cf_socket_sockaddrx_unit_t* sxPtr[2]; const struct sockaddr* saPtr[2]; int result; sxPtr[0] = Cf_socket_sockaddrx_unit_val(v1); saPtr[0] = &sxPtr[0]->sx_sockaddr; sxPtr[1] = Cf_socket_sockaddrx_unit_val(v2); saPtr[1] = &sxPtr[1]->sx_sockaddr; result = saPtr[0]->sa_family - saPtr[1]->sa_family; if (!result) { result = sxPtr[0]->sx_socklen - sxPtr[1]->sx_socklen; if (!result) { size_t ssLen = sxPtr[0]->sx_socklen; result = memcmp(saPtr[0]->sa_data, saPtr[1]->sa_data, ssLen); } } CAMLreturn(result); } static long cf_nameinfo_sockaddr_hash(value sxVal) { CAMLparam1(sxVal); const Cf_socket_sockaddrx_unit_t* sxPtr; const struct sockaddr* saPtr; unsigned long result; unsigned int i; sxPtr = Cf_socket_sockaddrx_unit_val(sxVal); saPtr = (const struct sockaddr*) &sxPtr->sx_sockaddr; for (result = 0, i = 0; i < sxPtr->sx_socklen; ++i) { unsigned long x = result >> 24; result <<= 8; result |= saPtr->sa_data[i] ^ x; } CAMLreturn((long) result); } static void cf_nameinfo_sockaddr_serialize (value sxVal, unsigned long* size32Ptr, unsigned long* size64Ptr) { CAMLparam1(sxVal); Cf_socket_sockaddrx_unit_t* sxPtr; size_t saLen, sxLen; sxPtr = Cf_socket_sockaddrx_unit_val(sxVal); sxLen = offsetof(Cf_socket_sockaddrx_unit_t, sx_sockaddr) + sxPtr->sx_socklen; serialize_int_1(sxPtr->sx_socklen); serialize_block_1((void*) &sxPtr->sx_sockaddr, sxPtr->sx_socklen); *size32Ptr = sxLen; *size64Ptr = sxLen; CAMLreturn0; } static unsigned long cf_nameinfo_sockaddr_deserialize(void* bufferPtr) { Cf_socket_sockaddrx_unit_t* sxPtr; size_t sxLen; sxPtr = (Cf_socket_sockaddrx_unit_t*) bufferPtr; sxPtr->sx_socklen = deserialize_uint_1(); deserialize_block_1((void*) &sxPtr->sx_sockaddr, sxPtr->sx_socklen); return offsetof(Cf_socket_sockaddrx_unit_t, sx_sockaddr) + sxPtr->sx_socklen; } static struct custom_operations cf_nameinfo_sockaddr_op = { "org.conjury.pagoda.cf.sockaddr_nameinfo", custom_finalize_default, cf_nameinfo_sockaddr_compare, cf_nameinfo_sockaddr_hash, cf_nameinfo_sockaddr_serialize, cf_nameinfo_sockaddr_deserialize }; value cf_nameinfo_sockaddr_cons(const struct sockaddr* saPtr, size_t saLen) { value sxVal; Cf_socket_sockaddrx_unit_t* sxPtr; const size_t sxLen = offsetof(Cf_socket_sockaddrx_unit_t, sx_sockaddr) + saLen; sxVal = alloc_custom(&cf_nameinfo_sockaddr_op, sxLen, 0, 1); sxPtr = Cf_socket_sockaddrx_unit_val(sxVal); if (sxPtr) { sxPtr->sx_socklen = saLen; memcpy(&sxPtr->sx_sockaddr, saPtr, saLen); #if defined(IN6_IS_ADDR_LINKLOCAL) /* a rude hack to work around common bugs on some BSD systems */ if (sxPtr->sx_sockaddr.sa_family == AF_INET6) { struct sockaddr_in6* sin6Ptr = (struct sockaddr_in6*) &sxPtr->sx_sockaddr; struct in6_addr* in6Ptr = &sin6Ptr->sin6_addr; if (IN6_IS_ADDR_LINKLOCAL(in6Ptr)) { uint16_t* u16Ptr = (uint16_t*) in6Ptr->s6_addr; if (sin6Ptr->sin6_scope_id == 0) sin6Ptr->sin6_scope_id = ntohs(u16Ptr[1]); u16Ptr[1] = 0; } } #endif } return sxVal; } static Cf_socket_domain_t cf_nameinfo_pf_unspec = { PF_UNSPEC, AF_UNSPEC, cf_nameinfo_sockaddr_cons, sizeof(struct sockaddr_storage) }; static value* cf_nameinfo_unresolved_exn = 0; static value cf_nameinfo_domain_val = Val_unit; static value cf_nameinfo_socktype_val = Val_unit; static value cf_nameinfo_protocol_val = Val_unit; static value cf_nameinfo_unspecified_val = Val_unit; static value cf_nameinfo_default_ai_flags_val = Val_unit; /*--- external domain_: unit -> unit Cf_socket.domain_t = "cf_nameinfo_domain" ---*/ CAMLprim value cf_nameinfo_domain(value unit) { CAMLparam0(); CAMLreturn(cf_nameinfo_domain_val); } /*--- external socktype_: unit -> unit Cf_socket.socktype_t = "cf_nameinfo_socktype" ---*/ CAMLprim value cf_nameinfo_socktype(value unit) { CAMLparam0(); CAMLreturn(cf_nameinfo_socktype_val); } /*--- external protocol_: unit -> Cf_socket.protocol_t = "cf_nameinfo_protocol" ---*/ CAMLprim value cf_nameinfo_protocol(value unit) { CAMLparam0(); CAMLreturn(cf_nameinfo_protocol_val); } /*--- external unspecified_: unit -> address_t = "cf_nameinfo_unspecified" ---*/ CAMLprim value cf_nameinfo_unspecified(value unit) { CAMLparam0(); CAMLreturn(cf_nameinfo_unspecified_val); } /*--- external default_ai_flags_: unit -> to_address_default_flags = "cf_nameinfo_default_ai_flags" ---*/ CAMLprim value cf_nameinfo_default_ai_flags(value unit) { CAMLparam0(); CAMLreturn(cf_nameinfo_default_ai_flags_val); } /*--- external is_specific_socktype: unit Cf_socket.socktype_t -> 'st Cf_socket.socktype_t -> bool = "cf_nameinfo_is_specific_socktype" ---*/ CAMLprim value cf_nameinfo_is_specific_socktype(value unitStVal, value xStVal) { CAMLparam2(unitStVal, xStVal); CAMLreturn(Val_bool(Nativeint_val(unitStVal) == Nativeint_val(xStVal))); } /*--- external is_specific_domain: unit Cf_socket.sockaddr_t -> 'af Cf_socket.domain_t -> bool = "cf_nameinfo_is_specific_domain" ---*/ CAMLprim value cf_nameinfo_is_specific_domain(value sxVal, value domainVal) { CAMLparam2(sxVal, domainVal); const Cf_socket_sockaddrx_unit_t* sxPtr; const Cf_socket_domain_t* domainPtr; int result; sxPtr = Cf_socket_sockaddrx_unit_val(sxVal); domainPtr = Cf_socket_domain_val(domainVal); result = !!((int) domainPtr->d_family == (int) sxPtr->sx_sockaddr.sa_family); CAMLreturn(Val_bool(result)); } /*--- external specialize_sockaddr: unit Cf_socket.sockaddr_t -> 'af Cf_socket.domain_t -> 'af Cf_socket.sockaddr_t = "cf_nameinfo_specialize_sockaddr" ---*/ CAMLprim value cf_nameinfo_specialize_sockaddr(value sxVal, value domainVal) { CAMLparam2(sxVal, domainVal); CAMLlocal2(resultVal, someVal); const Cf_socket_sockaddrx_unit_t* sxPtr; const Cf_socket_domain_t* domainPtr; sxPtr = Cf_socket_sockaddrx_unit_val(sxVal); domainPtr = Cf_socket_domain_val(domainVal); if ((int) domainPtr->d_family != (int) sxPtr->sx_sockaddr.sa_family) caml_raise_not_found(); resultVal = domainPtr->d_consaddr((struct sockaddr*) &sxPtr->sx_sockaddr, domainPtr->d_socklen); CAMLreturn(resultVal); } /*--- type unresolved_t = EAI_ADDRFAMILY | EAI_AGAIN | EAI_BADFLAGS | EAI_FAIL | EAI_FAMILY | EAI_MEMORY | EAI_NODATA | EAI_NONAME | EAI_SERVICE | EAI_SOCKTYPE | EAI_BADHINTS | EAI_PROTOCOL | EAI_UNKNOWN of int ---*/ static const int cf_nameinfo_unresolved_array[] = { /*EAI_ADDRFAMILY,*/ EAI_AGAIN, EAI_BADFLAGS, EAI_FAIL, EAI_FAMILY, EAI_MEMORY, /* EAI_NODATA, */ EAI_NONAME, EAI_SERVICE, EAI_SOCKTYPE, #ifdef EAI_BADHINTS EAI_BADHINTS, #endif #ifdef EAI_PROTOCOL EAI_PROTOCOL #endif }; #define CF_NAMEINFO_UNRESOLVED_ARRAY_SIZE \ (sizeof cf_nameinfo_unresolved_array / \ sizeof cf_nameinfo_unresolved_array[0]) value cf_nameinfo_unresolved_of_code(int error) { value resultVal; int i; for (i = 0; i < CF_NAMEINFO_UNRESOLVED_ARRAY_SIZE; ++i) if (cf_nameinfo_unresolved_array[i] == error) return Val_int(i); resultVal = alloc_small(1, 0); Store_field(resultVal, 0, Val_int(error)); return resultVal; } /*--- external error_message: unresolved_t -> string = "cf_nameinfo_error_message" ---*/ CAMLprim value cf_nameinfo_error_message(value codeVal) { CAMLparam1(codeVal); CAMLlocal1(resultVal); if (Is_block(codeVal)) { char buffer[128]; sprintf(buffer, "unknown error (code=%d)", (int) Int_val(Field(codeVal, 0))); resultVal = copy_string(buffer); } else { int code; const char* msgPtr; code = cf_nameinfo_unresolved_array[Int_val(codeVal)]; msgPtr = gai_strerror(code); resultVal = copy_string(msgPtr); } CAMLreturn(resultVal); } /*--- type of_address_flags_t = { ni_nofqdn: bool; ni_numerichost: bool; ni_namereqd: bool; ni_numericserv: bool; ni_dgram: bool; } ---*/ static const int cf_nameinfo_of_address_flags_array[] = { NI_NOFQDN, NI_NUMERICHOST, NI_NAMEREQD, NI_NUMERICSERV, NI_DGRAM, }; #define Cf_nameinfo_of_address_flags_array_size \ (sizeof cf_nameinfo_of_address_flags_array \ / sizeof cf_nameinfo_of_address_flags_array[0]) int cf_nameinfo_of_address_flags_to_int(value flagsVal) { int flags = 0; int i; for (i = 0; i < Cf_nameinfo_of_address_flags_array_size; ++i) if (Field(flagsVal, i) != Val_false) flags |= cf_nameinfo_of_address_flags_array[i]; return flags; } value cf_nameinfo_of_address_flags_of_int(int flags) { CAMLparam0(); CAMLlocal1(flagsVal); int i; flagsVal = alloc_small(Cf_nameinfo_of_address_flags_array_size, 0); for (i = 0; i < Cf_nameinfo_of_address_flags_array_size; ++i) Store_field(flagsVal, i, (flags & cf_nameinfo_of_address_flags_array[i]) ? Val_true : Val_false); CAMLreturn(flagsVal); } static void cf_nameinfo_raise_unresolved (int error, int syserror, const char* fname) { CAMLparam0(); CAMLlocal2(unresolvedVal, resultVal); if (!cf_nameinfo_unresolved_exn) cf_nameinfo_unresolved_exn = caml_named_value("Cf_nameinfo.Unresolved"); if (!cf_nameinfo_unresolved_exn) { char message[128]; sprintf (message, "Cf_nameinfo.%s: exception unavailable in primitive", fname); invalid_argument(message); } if (error == EAI_SYSTEM) unix_error(syserror, fname, Nothing); unresolvedVal = cf_nameinfo_unresolved_of_code(error); resultVal = alloc_small(2, 0); Store_field(resultVal, 0, *cf_nameinfo_unresolved_exn); Store_field(resultVal, 1, unresolvedVal); caml_raise(resultVal); CAMLreturn0; } /*--- external of_address: ?host:int -> ?serv:int -> ?flags:of_address_flags_t -> 'a Cf_socket.sockaddr_t -> string * string = "cf_nameinfo_of_address" ---*/ CAMLprim value cf_nameinfo_of_address (value hostLenVal, value servLenVal, value flagsVal, value sxVal) { CAMLparam4(hostLenVal, servLenVal, flagsVal, sxVal); CAMLlocal3(hostNameVal, servNameVal, resultVal); int error, syserror, flags; const Cf_socket_sockaddrx_unit_t* sxPtr; size_t ssLen, hostLen, servLen; char* hostName; char* servName; hostLen = NI_MAXHOST; if (Is_block(hostLenVal)) { int n = Int_val(Field(hostLenVal, 0)); if (n <= 0) INVALID_ARGUMENT("of_address: hostname length"); hostLen = (size_t) n; } servLen = NI_MAXSERV; if (Is_block(servLenVal)) { int n = Int_val(Field(servLenVal, 0)); if (n <= 0) INVALID_ARGUMENT("of_address: service name length"); servLen = (size_t) n; } hostName = malloc(hostLen); if (!hostName) unix_error(ENOMEM, "getnameinfo", Nothing); servName = malloc(servLen); if (!servName) { free(hostName); unix_error(ENOMEM, "getnameinfo", Nothing); } sxPtr = Cf_socket_sockaddrx_unit_val(sxVal); ssLen = sxPtr->sx_socklen; flags = 0; if (Is_block(flagsVal)) flags = cf_nameinfo_of_address_flags_to_int(Field(flagsVal, 0)); enter_blocking_section(); error = getnameinfo((const struct sockaddr*) &sxPtr->sx_sockaddr, ssLen, hostName, hostLen, servName, servLen, flags); syserror = errno; leave_blocking_section(); hostNameVal = copy_string(hostName); servNameVal = copy_string(servName); free(hostName); free(servName); if (error) cf_nameinfo_raise_unresolved(error, syserror, "getnameinfo"); resultVal = alloc_small(2, 0); Store_field(resultVal, 0, hostNameVal); Store_field(resultVal, 1, servNameVal); CAMLreturn(resultVal); } /*--- type to_address_arg_t = | A_nodename of string | A_servicename of string | A_bothnames of string * string type ('af, 'st) addrinfo = private { ai_flags: to_address_flags_t; ai_family: 'af Cf_socket.domain_t; ai_socktype: 'st Cf_socket.socktype_t; ai_protocol: Cf_socket.protocol_t; ai_cname: string option; ai_addr: 'af Cf_socket.sockaddr_t; } external to_address: ('af, 'st) addrinfo -> to_address_arg_t -> ('af, 'st) addrinfo list = "cf_nameinfo_to_addresses" ---*/ CAMLprim value cf_nameinfo_to_addresses(value hintVal, value argVal) { CAMLparam2(hintVal, argVal); CAMLlocal3(listVal, flagsVal, prevVal); CAMLlocal4(nextVal, infoVal, familyVal, socktypeVal); CAMLlocal4(protocolVal, cnameVal, addrVal, strVal); int error, syserror; const char* hostname; const char* servname; struct addrinfo hints; struct addrinfo* hintsPtr; struct addrinfo* resultPtr; listVal = Val_int(0); hostname = 0; servname = 0; hintsPtr = 0; resultPtr = 0; switch (Tag_val(argVal)) { case 0: hostname = String_val(Field(argVal, 0)); break; case 1: servname = String_val(Field(argVal, 0)); break; case 2: hostname = String_val(Field(argVal, 0)); servname = String_val(Field(argVal, 1)); break; } memset(&hints, 0, sizeof hints); flagsVal = Field(hintVal, 0); if (Bool_val(Field(flagsVal, 0))) hints.ai_flags |= AI_PASSIVE; if (Bool_val(Field(flagsVal, 1))) hints.ai_flags |= AI_CANONNAME; if (Bool_val(Field(flagsVal, 2))) hints.ai_flags |= AI_NUMERICHOST; hints.ai_family = Nativeint_val(Field(hintVal, 1)); hints.ai_socktype = Nativeint_val(Field(hintVal, 2)); hints.ai_protocol = Nativeint_val(Field(hintVal, 3)); if ( hints.ai_family != PF_UNSPEC || hints.ai_socktype != 0 || hints.ai_protocol != 0 || hints.ai_flags ) hintsPtr = &hints; enter_blocking_section(); error = getaddrinfo(hostname, servname, hintsPtr, &resultPtr); syserror = errno; leave_blocking_section(); if (error) cf_nameinfo_raise_unresolved(error, syserror, "getaddrinfo"); if (resultPtr) { const struct addrinfo* p; prevVal = Val_int(0); for (p = resultPtr; !!p; p = p->ai_next) { Cf_socket_domain_t domain; flagsVal = cf_nameinfo_default_ai_flags_val; if (p->ai_flags) { flagsVal = alloc_small(3, 0); 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; domain.d_domain = p->ai_family; domain.d_family = p->ai_family; familyVal = cf_socket_domain_alloc(&domain); socktypeVal = copy_nativeint(p->ai_socktype); protocolVal = copy_nativeint(p->ai_protocol); if (!p->ai_canonname) { cnameVal = Val_int(0); } else { strVal = copy_string(p->ai_canonname); cnameVal = alloc_small(1, 0); Store_field(cnameVal, 0, strVal); } addrVal = cf_nameinfo_sockaddr_cons(p->ai_addr, p->ai_addrlen); infoVal = alloc_small(6, 0); 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); Store_field(nextVal, 0, infoVal); Store_field(nextVal, 1, Val_int(0)); if (!Is_block(listVal)) listVal = nextVal; else modify(&Field(prevVal, 1), nextVal); prevVal = nextVal; } freeaddrinfo(resultPtr); } CAMLreturn(listVal); } /*--- Initialization primitive ---*/ CAMLprim value cf_nameinfo_init(value unit) { struct sockaddr_storage ss; struct sockaddr* saPtr; register_custom_operations(&cf_nameinfo_sockaddr_op); register_global_root(&cf_nameinfo_domain_val); cf_nameinfo_domain_val = cf_socket_domain_alloc(&cf_nameinfo_pf_unspec); register_global_root(&cf_nameinfo_socktype_val); cf_nameinfo_socktype_val = caml_copy_nativeint(0); register_global_root(&cf_nameinfo_protocol_val); cf_nameinfo_protocol_val = caml_copy_nativeint(0); register_global_root(&cf_nameinfo_unspecified_val); saPtr = (struct sockaddr*) &ss; memset(&ss, 0, sizeof ss); cf_nameinfo_unspecified_val = cf_nameinfo_pf_unspec.d_consaddr(saPtr, sizeof ss); register_global_root(&cf_nameinfo_default_ai_flags_val); cf_nameinfo_default_ai_flags_val = alloc_small(3, 0); 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; } /*--- End of File [ cf_nameinfo_p.c ] ---*/ cf-0.10/cf_nameinfo_p.h0000644000175000017500000000325210404616701014653 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_nameinfo_p.h Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_NAMEINFO_P_H #define _CF_NAMEINFO_P_H #include "cf_socket_p.h" #endif /* defined(_CF_NAMEINFO_P_H) */ /*--- End of File [ cf_nameinfo_p.h ] ---*/ cf-0.10/cf_netif.ml0000644000175000017500000000336510433520572014035 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_netif.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) external nametoindex: string -> int = "cf_netif_nametoindex" external indextoname: int -> string = "cf_netif_indextoname" external nameindex: unit -> (int * string) list = "cf_netif_nameindex" (*--- End of File [ cf_netif.ml ] ---*) cf-0.10/cf_netif.mli0000644000175000017500000000431210433520572014177 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_netif.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** Network interface name/index mapping. *) (** {6 Overview} Wrapper around the standard network interface name/index mapping functions defined in {[]}. *) (** Use [nametoindex name] to get the index for the interface [name]. Raises [Not_found] if the interface does not currently exist. *) val nametoindex: string -> int (** Use [indextoname index] to get the index for the interface [name]. Raises [Not_found] if the interface does not currently exist. *) val indextoname: int -> string (** Use [nameindex ()] to obtain the current list of network interfaces, by index and name. *) val nameindex: unit -> (int * string) list (*--- End of File [ cf_netif.mli ] ---*) cf-0.10/cf_netif_p.c0000644000175000017500000000651510404616701014164 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_netif_p.c Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_netif_p.h" #include #include #include #include /*--- external nametoindex: string -> int = "cf_netif_nametoindex" ---*/ CAMLprim value cf_netif_nametoindex(value nameVal) { CAMLparam1(nameVal); unsigned int n; n = if_nametoindex(String_val(nameVal)); if (!n) raise_not_found(); CAMLreturn(Val_int(n)); } /*--- external indextoname: string -> int = "cf_netif_indextoname" ---*/ CAMLprim value cf_netif_indextoname(value indexVal) { CAMLparam1(indexVal); CAMLlocal1(nameVal); char buffer[IF_NAMESIZE]; if (!if_indextoname(Int_val(indexVal), buffer)) raise_not_found(); nameVal = copy_string(buffer); CAMLreturn(nameVal); } /*--- external nameindex: unit -> (int * string) list = "cf_netif_nameindex" ---*/ CAMLprim value cf_netif_nameindex(value unit) { CAMLparam0(); CAMLlocal5(listVal, tailVal, nameVal, pairVal, cellVal); struct if_nameindex* mapPtr; struct if_nameindex* cellPtr; mapPtr = if_nameindex(); if (!mapPtr) unix_error(errno, "if_nameindex", Nothing); listVal = Val_int(0); tailVal = Val_int(0); for (cellPtr = mapPtr; cellPtr->if_name; cellPtr++) { nameVal = copy_string(cellPtr->if_name); pairVal = alloc_small(2, 0); Store_field(pairVal, 0, Val_int(cellPtr->if_index)); Store_field(pairVal, 1, nameVal); cellVal = alloc_small(2, 0); Store_field(cellVal, 0, pairVal); Store_field(cellVal, 1, Val_int(0)); if (!Is_block(listVal)) listVal = cellVal; else modify(&Field(tailVal, 1), cellVal); tailVal = cellVal; } if_freenameindex(mapPtr); CAMLreturn(listVal); } /*--- End of File [ cf_netif_p.c ] ---*/ cf-0.10/cf_netif_p.h0000644000175000017500000000323310404616701014163 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_netif_p.h Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_NETIF_P_H #define _CF_NETIF_P_H #include "cf_common_p.h" #endif /* defined(_CF_NETIF_P_H) */ /*--- End of File [ cf_netif_p.h ] ---*/ cf-0.10/cf_ordered.ml0000644000175000017500000000331410433520572014346 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_ordered.ml Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) module type Total_T = sig type t val compare: t -> t -> int end module Int_order = struct type t = int let compare a b = a - b end (*--- End of File [ cf_ordered.ml ] ---*) cf-0.10/cf_ordered.mli0000644000175000017500000000461110433520572014520 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_ordered.mli Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) (** Ordered types. A functor for composing key-value pairs using an associated total ordering function. This is used in data structure modules like {!Cf_rbtree} and {!Cf_sbheap}. *) (** The module type defining a type [t] and a corresponding function to give the total order of all values of that type. *) module type Total_T = sig (** An abstract type *) type t (** [compare a b] compares the total ordering of [a] and [b], and it returns zero if the two values are of equal total order, a negative integer if [a] follows [b], and a positive integer if [a] precedes [b] in the total ordering. The [Pervasives.compare] function is a suitable value in modules of this type. *) val compare: t -> t -> int end (** The order of integers. *) module Int_order: Total_T with type t = int (*--- End of File [ cf_ordered.mli ] ---*) cf-0.10/cf_parser.ml0000644000175000017500000001751210450665544014233 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_parser.ml Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) type ('s, 'a) t = 's Cf_seq.t -> ('a * 's Cf_seq.t) option exception Error let nil _ = None let err_aux_ _ = Error let err ?(f = err_aux_) () s = raise (f s) let req ?f p s = match p s with None -> err ?f () s | x -> x let fin s = match Lazy.force s with | Cf_seq.Z -> Some ((), s) | _ -> None let rec alt a s = match a with | [] -> None | hd :: tl -> match hd s with | None -> alt tl s | v -> v let rec altz pz s = match Lazy.force pz with | Cf_seq.Z -> None | Cf_seq.P (hd, tl) -> match hd s with | None -> altz tl s | v -> v let sat f s = match Lazy.force s with | Cf_seq.P (i, tl) when f i -> Some (i, tl) | _ -> None let tok f s = match Lazy.force s with | Cf_seq.Z -> None | Cf_seq.P (hd, tl) -> match f hd with | None -> None | Some x -> Some (x, tl) let lit k x = let klen = String.length k in let rec loop i s = if i < klen then match Lazy.force s with | Cf_seq.P (hd, tl) when String.unsafe_get k i = hd -> loop (succ i) tl | _ -> None else Some (x, s) in fun s -> loop 0 s let rec unfold p s = lazy begin match p s with | None -> Cf_seq.Z | Some (x, s) -> Cf_seq.P (x, unfold p s) end class ['a] cursor init = object val position_: int = init method advance (_: 'a) = {< position_ = succ position_ >} method position = position_ end module type X = sig type ('c, 'i, 'o) t = 'z Cf_seq.t -> ('o * 'z Cf_seq.t) option constraint 'z = 'i * 'c constraint 'c = 'x #cursor exception Error of int val err: ?f:(('i * 'c) Cf_seq.t -> exn) -> unit -> ('c, 'i, 'o) t val req: ?f:(('i * 'c) Cf_seq.t -> exn) -> ('c, 'i, 'o) t -> ('c, 'i, 'o) t val sat: ('i -> bool) -> ('c, 'i, 'i) t val tok: ('i -> 'o option) -> ('c, 'i, 'o) t val lit: string -> 'o -> ('c, char, 'o) t val weave: c:('i #cursor as 'c) -> 'i Cf_seq.t -> ('i * 'c) Cf_seq.t val unfold: ('c, 'i, 'o) t -> ('i * 'c) Cf_seq.t -> ('o * 'c) Cf_seq.t end module X: X = struct type ('c, 'i, 'o) t = 'z Cf_seq.t -> ('o * 'z Cf_seq.t) option constraint 'z = 'i * 'c constraint 'c = 'x #cursor exception Error of int let err_aux_ s = Error begin match Lazy.force s with | Cf_seq.Z -> (-1) | Cf_seq.P ((_, c), _) -> c#position end let err ?(f = err_aux_) () s = raise (f s) let req ?f p s = match p s with None -> err ?f () s | x -> x let sat f s = match Lazy.force s with | Cf_seq.P ((i, _), tl) when f i -> Some (i, tl) | _ -> None let tok f s = match Lazy.force s with | Cf_seq.Z -> None | Cf_seq.P ((hd, _), tl) -> match f hd with | None -> None | Some x -> Some (x, tl) let lit k x = let klen = String.length k in let rec loop i s = if i < klen then match Lazy.force s with | Cf_seq.P ((hd, _), tl) when String.unsafe_get k i = hd -> loop (succ i) tl | _ -> None else Some (x, s) in fun s -> loop 0 s let rec weave ~c s = lazy begin match Lazy.force s with | Cf_seq.P (hd, tl) -> Cf_seq.P ((hd, c), weave ~c:(c#advance hd) tl) | Cf_seq.Z -> Cf_seq.Z end let rec unfold p s = lazy begin match Lazy.force s with | Cf_seq.Z -> Cf_seq.Z | Cf_seq.P ((_, c), _) -> match p s with | None -> Cf_seq.Z | Some (x, s) -> Cf_seq.P ((x, c), unfold p s) end end module Op = struct let ( >>= ) m f s = match m s with None -> None | Some (a, s) -> f a s let ( ~: ) a s = Some (a, s) let ( ?. ) i0 s = match Lazy.force s with | Cf_seq.P (i, tl) when i = i0 -> Some (i0, tl) | _ -> None let ( ?: ) i0 s = match Lazy.force s with | Cf_seq.P ((i, _), tl) when i = i0 -> Some (i0, tl) | _ -> None let ( ?/ ) p c = Some (match p c with None -> None, c | Some (y, c) -> Some y, c) let ( ?* ) p = let rec loop stack c = match p c with | None -> Some (List.rev stack, c) | Some (x, c) -> loop (x :: stack) c in fun c -> loop [] c let ( ?+ ) p = p >>= fun hd -> ?*p >>= fun tl -> ~: (hd, tl) let ( %= ) p q seq = match Lazy.force seq with | Cf_seq.Z -> begin match q (X.unfold p Cf_seq.nil) with | None -> None | Some (x, _) -> Some (x, Cf_seq.nil) end | Cf_seq.P ((_, c0), _) -> match q (X.unfold p seq) with | None -> None | Some (x, seq') -> let seq'' = match Lazy.force seq' with | Cf_seq.Z -> Cf_seq.nil | Cf_seq.P ((_, c1), _) -> Cf_seq.shift (c1#position - c0#position) seq in 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) let rec to_extended_aux_ n fin s = let z = Lazy.force s in if fin == z then n else match z with | Cf_seq.P (_, tl) -> to_extended_aux_ (succ n) fin tl | Cf_seq.Z -> assert (not true); n let to_extended p s = let s0 = Cf_seq.first s in match p s0 with | Some (x, s1) -> let fin = Lazy.force s1 in Some (x, Cf_seq.shift (to_extended_aux_ 0 fin s0) s) | None -> None let of_extended c p s = match p (X.weave ~c s) with | Some (x, s) -> Some (x, Cf_seq.first s) | None -> None (*--- End of File [ cf_parser.ml ] ---*) cf-0.10/cf_parser.mli0000644000175000017500000002651010433520572014372 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_parser.mli Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) (** Functional LL(x) parsing with monadic combinators. *) (** This module implements function left-shift/left-reduce parser combinators using a state-exception monad over the input stream. To evaluate a parser monad is to parse an input stream. The state monad is lifted into the exception monad to facilitate backtracking. Parsers should signal errors in the input stream with ordinary Objective Caml exceptions. *) (** The parser monad. A function that parses a sequence of input tokens. Returns [None] if the parser does not recognize any symbols. Otherwise returns the reduced output and the remainder of the input tokens. *) type ('i, 'o) t = 'i Cf_seq.t -> ('o * 'i Cf_seq.t) option (** Generic parser error with no parameters. *) exception Error (** 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 the input token stream to the optional function [f] to obtain an Objective Caml exception, then raises the exception. The default function simply raises [Error]. *) val err: ?f:('i Cf_seq.t -> exn) -> unit -> ('i, 'x) t (** Use [req f p] to create a parser that requires the input stream to match the parser [p] or it will be passed to the parser [err f] instead. *) val req: ?f:('i Cf_seq.t -> exn) -> ('i, 'o) t -> ('i, 'o) t (** A parser that produces the unit value when it recognizes the end of the input token sequence. *) val fin: ('i, unit) t (** Use [alt plist] to create a parser that produces the output from the first parser in the list [plist] that recognizes a pattern in the input. If no parser in the list recognizes a pattern, then the parser constructed by this function returns [None]. *) val alt: ('i, 'o) t list -> ('i, 'o) t (** Use [altz pseq] to create a parser that produces the output from the first parser in the lazy sequence [pseq] that recognizes a pattern in the input. If no parser in the sequence recognizes a pattern, then the parser constructed by this function returns [None]. *) val altz: ('i, 'o) t Cf_seq.t -> ('i, 'o) t (** Use [sat f] to create a parser that recognizes, shifts and reduces input tokens for which the satisfier function [f] returns [true]. *) val sat: ('i -> bool) -> ('i, 'i) t (** Use [tok f] to recognize and shift input tokens for which the tokenizer function [f] reduces an output value. *) val tok: ('i -> 'o option) -> ('i, 'o) t (** Use [lit s obj] to obtain a parser on character input sequences that produces the output [obj] when it recognizes the literal [s] in the input. *) val lit: string -> 'o -> (char, 'o) t (** Use [unfold p i] to create a sequence of output values recognized by applying the input token sequence [i] to the parser [p] until no more input is recognized. *) val unfold: ('i, 'o) t -> 'i Cf_seq.t -> 'o Cf_seq.t (** A class useful for tracking the position in the input token stream that corresponds to the head of the sequence passed to a parser. The [#cursor] class type is used in the [X] module defined below. *) class ['i] cursor: int -> (** The initial position, i.e. usually zero *) object('self) val position_: int (** The current position *) (** Use [c#advance i] to construct a new object corresponding to the new input position after reading an input symbol [i]. *) method advance: 'i -> 'self (** Returns the current position. *) method position: int end (** A module of parser extensions for working with input sequences that require position information in the parse function. *) module X: sig (** A parser where every token in the input sequence is accompanied by a {!Cf_parser.cursor} class object. *) type ('c, 'i, 'o) t = 'z Cf_seq.t -> ('o * 'z Cf_seq.t) option constraint 'z = 'i * 'c constraint 'c = 'x #cursor (** Generic parser error with one positional parameter. *) exception Error of int (** Use [err ?f ()] to compose parser that applies the input token stream to the optional function [f] to obtain an Objective Caml exception, then raises the exception. The default function simply raises [Error]. *) val err: ?f:(('i * 'c) Cf_seq.t -> exn) -> unit -> ('c, 'i, 'o) t (** Use [req ?f p] to create a parser that requires the input stream to match the parser [p] or it will be passed to the parser [err ?f ()] instead. *) val req: ?f:(('i * 'c) Cf_seq.t -> exn) -> ('c, 'i, 'o) t -> ('c, 'i, 'o) t (** Use [sat f] to create a parser that recognizes, shifts and reduces input tokens for which the satisfier function [f] returns [true]. *) val sat: ('i -> bool) -> ('c, 'i, 'i) t (** Use [tok f] to recognize and shift input tokens for which the tokenizer function [f] reduces an output value. *) val tok: ('i -> 'o option) -> ('c, 'i, 'o) t (** Use [lit s obj] to obtain a parser on character input sequences that produces the output [obj] when it recognizes the literal [s] in the input. *) val lit: string -> 'o -> ('c, char, 'o) t (** Use [weave ~c i] with an initial cursor [c] and an input sequence [i] to create an input sequence with accompanying cursor. *) val weave: c:('i #cursor as 'c) -> 'i Cf_seq.t -> ('i * 'c) Cf_seq.t (** Use [unfold p i] to create a sequence of output values recognized by applying the input token sequence [i] to the parser [p] until no more input is recognized. The cursor objects in the output sequence elements correspond to the positions of the input sequence at the start of where the output was recognized. *) val unfold: ('c, 'i, 'o) t -> ('i * 'c) Cf_seq.t -> ('o * 'c) Cf_seq.t end (** Open this module to take the parser operators into the current scope. *) module Op: sig (** The binding operator. Use [p >>= f] to compose a parser that passes output of parser [p] to the bound function [f] which returns the parser for the next symbol in a parsing rule. *) val ( >>= ): ('i, 'a) t -> ('a -> ('i, 'b) t) -> ('i, 'b) t (** The return operator. Use [~:obj] to create a parser that produces the value [obj] as its result without processing any more input. *) val ( ~: ): 'o -> ('i, 'o) t (** The unit operator. Use [?.token] to create a parser that recognizes [token] at the head of the input stream and produces it as its output. *) val ( ?. ): 'i -> ('i, 'i) t (** The unit operator with a cursor. Use [?:token] to create a parser that recognizes [token] at the head of a position attributed input stream and produces it as its output. *) val ( ?: ): 'i -> ('c, 'i, 'i) X.t (** The option operator. Use [?/p] to create a parser that recognizes an optional symbol in the input stream with the parser [p]. If the symbol is recognized, its tokens are shifted and reduced as [Some obj], otherwise no tokens are shifted and the reduced value is [None]. Parser functions created with this operator {i always} return [Some r], where [r] is the reduced value, i.e. either [Some obj] or [None]. *) val ( ?/ ): ('i, 'o) t -> ('i, 'o option) t (** The zero-or-more operator. Use [?*p] to create a parser that recognizes zero or more symbols in the input stream with the parser [p]. The tokens of all the symbols recognized are shifted and reduced as a list of objects in the order of their appearance in the input stream. Parser functions created with this operator {i always} return [Some r], where [r] is the reduced list of symbols, which may be the empty list if there are no symbols recognized. *) val ( ?* ): ('i, 'o) t -> ('i, 'o list) t (** The one-or-more operator. Use [?+p] to create a parser that recognizes one or more symbols in the input stream with the parser [p]. If the symbols are recognized in the input stream, then their tokens are shifted and reduced into a list of objects in the order of their appearance in the input stream. Otherwise, no tokens are shifted and no output is reduced. *) val ( ?+ ): ('i, 'o) t -> ('i, 'o * 'o list) t (** The serial composition operator. Use [p1 %= p2] to unfold the output token stream of parser [p1] and use it as the input token stream for parser [p2]. This is useful in the case that [p1] is a lexical analyzer created with the {!Cf_lex} module, and [p2] is a grammar that operates at the level of lexical tokens output by [p1]. *) 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 (** Use [to_extended p] to convert the parser [p] into an extended parser that ignores the position information woven into the input stream. *) val to_extended: ('i, 'o) t -> ('c, 'i, 'o) X.t (** Use [of_extended c p] to convert the parser [p] that requires position information in the input stream into a parser that assumes the input begins at the position of the cursor [c]. *) val of_extended: ('i #cursor as 'c) -> ('c, 'i, 'o) X.t -> ('i, 'o) t (*--- End of File [ cf_parser.mli ] ---*) cf-0.10/cf_poll.ml0000644000175000017500000003175110454115227013676 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_poll.ml Copyright (c) 2003-2006, 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 jout = Cf_journal.stdout *) module Fd_order = struct type t = Unix.file_descr let compare = Pervasives.compare end module Fd_map = Cf_rbtree.Map(Fd_order) module Tm_order = struct type t = Cf_tai64n.t let compare a b = - (Cf_tai64n.compare a b) end module Tm_heap = Cf_sbheap.PQueue(Tm_order) module Sig_order = Cf_ordered.Int_order module Sig_map = Cf_rbtree.Map(Sig_order) type t = { p_fd_r_aux_: fd_aux_t; p_fd_w_aux_: fd_aux_t; p_fd_x_aux_: fd_aux_t; mutable p_tm_heap_: ((unit -> unit) * Obj.t) Tm_heap.t; mutable p_sig_map_: (Sys.signal_behavior * (unit -> unit)) Sig_map.t; mutable p_sig_zlist_: int list Lazy.t; mutable p_sig_stack_: int list; mutable p_idle_queue_: ((Cf_tai64n.t -> unit) * Obj.t) Cf_deque.t; } and fd_aux_t = { mutable fd_map_: (unit -> unit) Fd_map.t; mutable fd_zlist_: Unix.file_descr list Lazy.t } type more = More | Last let fd_aux_create_ () = { fd_map_ = Fd_map.nil; fd_zlist_ = Lazy.lazy_from_val []; } let fd_aux_zlist_ m = lazy (Cf_seq.reverse (Cf_seq.first (Fd_map.to_seq_decr m))) let fd_aux_modify_ f aux = let m = f aux.fd_map_ in aux.fd_map_ <- m; aux.fd_zlist_ <- fd_aux_zlist_ m let rec fd_service_ aux = function | [] -> () | hd :: tl -> (Fd_map.search hd aux.fd_map_) (); fd_service_ aux tl let tm_compute_ now p = try let mark, _ = Tm_heap.head p.p_tm_heap_ in let dt = Cf_tai64n.sub mark now in if dt > 0.0 then dt else 0.0 with | Not_found -> -1.0 let rec tm_service_ p now = match try let mark, (call, _) = Tm_heap.head p.p_tm_heap_ in let dt = Cf_tai64n.sub mark now in if dt > 0.0 then None else Some call with | Not_found -> None with | None -> () | Some call -> p.p_tm_heap_ <- Tm_heap.tail p.p_tm_heap_; call (); tm_service_ p now let sig_handler_ p n = p.p_sig_stack_ <- n :: p.p_sig_stack_ let sig_zlist_ m = lazy (Cf_seq.reverse (Cf_seq.first (Sig_map.to_seq_decr m))) let sig_register_ p n call = let save = Sys.signal n (Sys.Signal_handle (sig_handler_ p)) in let m = Sig_map.replace (n, (save, call)) p.p_sig_map_ in p.p_sig_map_ <- m; p.p_sig_zlist_ <- sig_zlist_ m let sig_unregister_ p n = let (save, _), m = Sig_map.extract n p.p_sig_map_ in let _ = Sys.signal n save in p.p_sig_map_ <- m; p.p_sig_zlist_ <- sig_zlist_ m let sig_service_ p = let rec loop = function | hd :: tl -> let _, call = Sig_map.search hd p.p_sig_map_ in call (); loop tl | [] -> () in let stack = p.p_sig_stack_ in p.p_sig_stack_ <- []; loop stack let idle_service_ p now = match Cf_deque.B.pop p.p_idle_queue_ with | Some ((call, _), tl) -> p.p_idle_queue_ <- tl; call now | None -> () let create () = { p_fd_r_aux_ = fd_aux_create_ (); p_fd_w_aux_ = fd_aux_create_ (); p_fd_x_aux_ = fd_aux_create_ (); p_tm_heap_ = Tm_heap.nil; p_sig_map_ = Sig_map.nil; p_sig_zlist_ = Lazy.lazy_from_val []; p_sig_stack_ = []; p_idle_queue_ = Cf_deque.nil; } type select_t = | S_select of ((Unix.file_descr list as 'a) * 'a * 'a) | S_error of exn | S_interrupt let cycle p = let now = Cf_tai64n.now () in let dt = tm_compute_ now p in let rlist = Lazy.force p.p_fd_r_aux_.fd_zlist_ in let wlist = Lazy.force p.p_fd_w_aux_.fd_zlist_ in let xlist = Lazy.force p.p_fd_x_aux_.fd_zlist_ in let sigs = Lazy.force p.p_sig_zlist_ in let idling = not (Cf_deque.empty p.p_idle_queue_) in match rlist, wlist, xlist with | [], [], [] when dt < 0.0 && sigs = [] && not idling -> (* assert (jout#debug "Cf_poll.cycle: done."); *) Last | _, _, _ when dt = 0.0 -> tm_service_ p now; More | _, _, _ -> if idling then idle_service_ p now; (* assert begin let buf = Buffer.create 32 in Buffer.add_char buf '['; List.iter begin fun n -> Buffer.add_string buf (Printf.sprintf " %d" n); end sigs; Buffer.add_string buf " ]"; let sigstr = Buffer.contents buf in jout#debug "Cf_poll.cycle: dt=%f sigs=%s fdsetlen=(%d,%d,%d)" dt sigstr (List.length rlist) (List.length wlist) (List.length xlist) end; *) let save = Unix.sigprocmask Unix.SIG_UNBLOCK sigs in let event = try S_select (Unix.select rlist wlist xlist dt) with | Unix.Unix_error (e, _, _) when e = Unix.EINTR -> S_interrupt | x -> S_error x in let _ = Unix.sigprocmask Unix.SIG_SETMASK save in let now = Cf_tai64n.now () in match event with | S_select (rlist', wlist', xlist') -> fd_service_ p.p_fd_x_aux_ xlist'; fd_service_ p.p_fd_w_aux_ wlist'; fd_service_ p.p_fd_r_aux_ rlist'; tm_service_ p now; More | S_interrupt -> sig_service_ p; More | S_error e -> raise e exception Not_ready type 'a state = | Unloaded | Loaded of t | Working of t * 'a | Final of 'a | Exception of exn class type ['a] event = object val mutable state_: 'a state val mutable put_: Queue.t option method private service: t -> 'a state method private load_: t -> unit method private unload_: t -> unit method load: ?q:( Queue.t) -> t -> unit method unload: unit method canget: bool method get: 'a end class virtual ['a] core = object(self:'self) constraint 'self = 'a #event val mutable state_ = Unloaded val mutable put_ = None method private virtual load_: t -> unit method private virtual unload_: t -> unit method private virtual service: t -> 'outcome method private put_ = match put_ with | Some q -> Queue.add (self :> ) q | None -> () method private callback_ p () = state_ <- try match self#service p with | Final _ as s -> self#put_; self#unload_ p; s | (Exception _ | Working (_, _)) as s -> self#put_; s | s -> s with | e -> self#put_; self#unload_ p; Exception e method load ?q p = match state_ with | Loaded p0 when p0 == p-> put_ <- q | Loaded p0 -> self#unload_ p0; state_ <- Loaded p; put_ <- q; self#load_ p | Working (p0, _) when p0 == p -> put_ <- q; | Working (p0, v) -> self#unload_ p0; state_ <- Working (p, v); put_ <- q; self#load_ p | Unloaded | Final _ | Exception _ -> state_ <- Loaded p; put_ <- q; self#load_ p method unload = match state_ with | Loaded p -> self#unload_ p; put_ <- None; state_ <- Unloaded | Working (p, v) -> self#unload_ p; put_ <- None; state_ <- Final v | Unloaded | Final _ | Exception _ -> put_ <- None; state_ <- Unloaded method canget = match state_ with | (Working _ | Final _ | Exception _) -> true | (Loaded _ | Unloaded) -> false method get = match state_ with | (Unloaded | Loaded _) -> raise Not_ready | (Working (_, v) | Final v) -> v | Exception e -> raise e end type rwx = [ `R | `W | `X ] let fd_aux_of_mode_ = let r p = p.p_fd_r_aux_ in let w p = p.p_fd_w_aux_ in let x p = p.p_fd_w_aux_ in function `R -> r | `W -> w | `X -> x class virtual ['a] file rwx fd = let aux = fd_aux_of_mode_ rwx in object(self:'self) inherit ['a] core as super method private virtual service: t -> 'a state method private load_ p = let aux = aux p in let pair = fd, (self#callback_ p) in let m, old = Fd_map.insert pair aux.fd_map_ in aux.fd_map_ <- m; if old = None then aux.fd_zlist_ <- fd_aux_zlist_ m method private unload_ p = let aux = aux p in try let _, m = Fd_map.extract fd aux.fd_map_ in aux.fd_map_ <- m; aux.fd_zlist_ <- fd_aux_zlist_ m; with | Not_found -> () end class virtual ['a] signal (n: int) = object inherit ['a] core as super method private load_ p = sig_register_ p n (super#callback_ p) method private unload_ p = sig_unregister_ p n end class virtual ['a] time ?t0 interval = object(self:'self) inherit ['a] core as super val mutable epoch_ = match t0 with | Some epoch -> epoch | None -> Cf_tai64n.add (Cf_tai64n.now ()) interval method private callback_ p () = state_ <- (try self#service p with e -> Exception e); begin match state_ with | Loaded _ | Working (_, _) -> if interval > 0.0 then begin epoch_ <- Cf_tai64n.add epoch_ interval; self#load_ p end | _ -> () end; super#put_ method private load_ p = let v = epoch_, (self#callback_ p, Obj.repr self) in p.p_tm_heap_ <- Tm_heap.put v p.p_tm_heap_ method private unload_ p = let f (_, (_, obj)) = Obj.repr self != obj in p.p_tm_heap_ <- Tm_heap.filter f p.p_tm_heap_ end class virtual ['a] idle = object(self:'self) inherit ['a] core as super val mutable epoch_: Cf_tai64n.t option = None method private callback_with_time_ p now = state_ <- begin try epoch_ <- Some now; self#service p with | e -> epoch_ <- None; Exception e end; begin match state_ with | Loaded _ | Working (_, _) -> self#load_ p | _ -> () end; super#put_ method private load_ p = epoch_ <- None; let v = self#callback_with_time_ p, Obj.repr self in p.p_idle_queue_ <- Cf_deque.A.push v p.p_idle_queue_ method private unload_ p = epoch_ <- None; let f (_, obj) = Obj.repr self != obj in p.p_idle_queue_ <- Cf_deque.filter f p.p_idle_queue_ method get = let v = super#get in epoch_ <- None; v end (*--- End of File [ cf_poll.ml ] ---*) cf-0.10/cf_poll.mli0000644000175000017500000001702710433520572014047 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_poll.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** I/O event multiplexing. *) (** {6 Overview} This module implements an abstraction useful for multiplexing I/O events within a single thread of control. Use this module in cases when a program must block until an I/O event is ready at one of a collection of system resources. {b Note}: On some platforms in the future, this module may be implemented around a specialized kernel event queue, e.g. {i /dev/poll } on Solaris, or {i kevent/kqueue } on Mac OS X. In this early implementation, however, the module is implemented as a wrapper around [Unix.select] on all platforms. *) (** {6 Types} *) (** A polling mux. *) type t (** The sum type of results from cycling a polling mux. *) type more = More | Last (** The basic polymorphic sum type for the state of an I/O event. Specializations of the basic I/O event class type may need more states. The basic states are: {ul {- [`Unloaded], not loaded into a polling event queue.} {- [`Loaded q], loaded into the polling event queue [q].} {- [`Final v] finished with a normal result [v].} {- [`Exception x], finished with an exceptional result [x].} } *) type 'a state = | Unloaded (* Not loaded into a polling mux. *) | Loaded of t (* Loaded and pending in a polling mux. *) | Working of t * 'a (* Loaded while intermediate result available. *) | Final of 'a (* Finished with a normal result. *) | Exception of exn (* Finished with an exceptional result. *) (** The type of objects representing an I/O events that produce results of type ['a]. *) class type virtual ['a] event = object (** The current state of the I/O event. *) val mutable state_: 'a state (** An optional queue of I/O events producing results of type ['a] provided in the [load] method. *) val mutable put_: Queue.t option (** The [self#service p] method is invoked in the cycle for the polling mux [p] when the event is ready to be serviced. The method is virtual to accomodate specializations with intermediate state and event handling functionality. *) method private virtual service: t -> 'a state (** The [self#load_ p] method is invoked in the [load] method to load the specialized event into the polling mux [p]. *) method private load_: t -> unit (** The [self#unload_ p] method is invoked in the [unload] method to unload the specialized event from the polling mux [p]. *) method private unload_: t -> unit (** Use [obj#load ?q p] to load the event into the collection of pending events at the polling mux [p]. Sets the [state_] member to [`Loaded p]. If the event is already loaded into a polling mux, it is unloaded first. If the optional [?q] argument is provided, then the [put_] member is set accordingly. *) method load: ?q:( Queue.t) -> t -> unit (** Use [obj#unload] to remove the event from the collection of pending events in a polling mux. Sets the [state_] member to [`Unloaded]. *) method unload: unit (** Returns [false] if the event requires service by a polling mux before a result may be obtained with the [get] method. *) method canget: bool (** Get the final result of the I/O event. Raises [Not_ready] if the event requires more service by a polling mux. If the state of the event is [`Exception x], then the exception [x] is raised. *) method get: 'a end (** The exception raised when the [get] method is applied to an I/O event object that has not been serviced by a polling mux. *) exception Not_ready (** {6 Functions and Classes} To use a polling mux, follow these steps: - construct a mux with [create ()]; - construct any number of [file], [signal], [time] and [idle] I/O events; - apply the [load] method on each one using the new mux; - apply the [cycle] function to the mux; - apply the [canget] and [get] methods to the events to obtain the results. *) (** Use [create ()] to construct a new polling mux. *) val create: unit -> t (** Use [cycle p] to wait until one or more of the I/O event objects loaded into the mux [p] is ready to be serviced, then service them (which includes invoking their [obj#service] method). Returns [Last] if there are no more events loaded into the polling mux. Otherwise, returns [More]. *) val cycle: t -> more (** File events are associated with read, write or exception I/O events. *) type rwx = [ `R | `W | `X ] (** Use [inherit file rwx fd] to derive an I/O event object that waits for the file descriptor [fd] to be ready for reading, writing, or exception (according to the value of [rwx]). *) class virtual ['a] file: [< rwx ] -> Unix.file_descr -> ['a] event (** Use [inherit signal n] to derive an I/O event that is serviced when the system delivers the signal [n]. *) class virtual ['a] signal: int -> ['a] event (** Use [inherit time ?start interval] to derive an I/O event that is serviced after the system clock reaches a specific time and at constrant intervals thereafter. If [?start] is not provided, then the start time is immediately after the first interval. *) class virtual ['a] time: ?t0:Cf_tai64n.t -> float -> object inherit ['a] event (** The epoch when the event is to be serviced. *) val mutable epoch_: Cf_tai64n.t end (** Use [inherit idle] to derive an I/O event that is serviced whenever a polling mux cycle would otherwise block for any non-zero length of time. *) class virtual ['a] idle: object inherit ['a] event (** The epoch when the event is was serviced. *) val mutable epoch_: Cf_tai64n.t option end (*--- End of File [ cf_poll.mli ] ---*) cf-0.10/cf_pqueue.ml0000644000175000017500000000473410433520572014235 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_pqueue.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) module type T = sig type +'a t module Key: sig type t end val nil: 'a t val empty: 'a t -> bool val size: 'a t -> int val head: 'a t -> (Key.t * 'a) val tail: 'a t -> 'a t val pop: 'a t -> ((Key.t * 'a) * 'a t) option val put: (Key.t * 'a) -> 'a t -> 'a t val merge: 'a t -> 'a t -> 'a t val iterate: ((Key.t * 'a) -> unit) -> 'a t -> unit val predicate: ((Key.t * 'a) -> bool) -> 'a t -> bool val fold: ('b -> (Key.t * 'a) -> 'b) -> 'b -> 'a t -> 'b val filter: ((Key.t * 'a) -> bool) -> 'a t -> 'a t val map: ((Key.t * 'a) -> 'b) -> 'a t -> 'b t val optmap: ((Key.t * 'a) -> 'b option) -> 'a t -> 'b t val partition: ((Key.t * 'a) -> bool) -> 'a t -> 'a t * 'a t val of_seq: (Key.t * 'a) Cf_seq.t -> 'a t val of_list: (Key.t * 'a) list -> 'a t val to_seq: 'a t -> (Key.t * 'a) Cf_seq.t val to_seq2: 'a t -> ((Key.t * 'a) * 'a t) Cf_seq.t end (*--- End of File [ cf_pqueue.ml ] ---*) cf-0.10/cf_pqueue.mli0000644000175000017500000001465210433520572014406 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_pqueue.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** A module type for functional priority queue implementations. *) (** {6 Module Type} *) (** This module defines the common interface to functional priority queues in the {!Cf} library. *) module type T = sig (** The priority queue type *) type +'a t (** A module defining the type of the key. Some map implementations may define more functions in this module for disambiguating keys from one another. *) module Key: sig type t end (** The empty priority queue. *) val nil: 'a t (** Use [empty q] to test whether the priority queue [q] is empty. *) val empty: 'a t -> bool (** Use [size q] to count the number of elements in the priority queue [q]. *) val size: 'a t -> int (** Use [head q] to obtain the element on the top of the priority queue [q]. Raises [Not_found] if the queue is empty. *) val head: 'a t -> (Key.t * 'a) (** Use [tail q] to obtain the heap produced by discarding the element on the top of the priority queue [q]. If [q] is the empty queue, then the empty queue is returned. *) val tail: 'a t -> 'a t (** Use [pop q] to obtain the head and the tail of a priority queue [q] in one operation. Returns [None] if the queue [q] is empty. *) val pop: 'a t -> ((Key.t * 'a) * 'a t) option (** Use [put e q] to obtain a new priority queue that is the result of inserting the element [e] into the queue [q]. *) val put: (Key.t * 'a) -> 'a t -> 'a t (** Use [merge q1 q2] to obtain a new priority queue that is the result of merging all the elements of [q1] and [q2] into a single heap. *) val merge: 'a t -> 'a t -> 'a t (** Use [iterate f q] to apply [f] to every element in the priority queue [q] in an arbitrary order (not top to bottom). *) val iterate: ((Key.t * 'a) -> unit) -> 'a t -> unit (** Use [predicate f q] to test whether all the elements in priority queue [q] satisfy the predicate function [f]. Visits the elements in the queue in arbitrary order (not top to bottom). *) val predicate: ((Key.t * 'a) -> bool) -> 'a t -> bool (** Use [fold f s q] to produce the result of folding a value [s] into the elements of priority queue [q] with the folding function [f] in an arbitrary order (not top to bottom). *) val fold: ('b -> (Key.t * 'a) -> 'b) -> 'b -> 'a t -> 'b (** Use [filter f q] to apply [f] to each element in the priority queue [q] in an arbitrary order (not to top bottom), and produce a new heap that contains only those elements for which [f pair] returned [true]. *) val filter: ((Key.t * 'a) -> bool) -> 'a t -> 'a t (** Use [map f q] to obtain a new heap by applying the mapping function [f] to the key and the value of every element in the priority queue [q] to obtain a mapped element with the same key and a new value. The elements of [q] are visited in an arbitrary order (not top to bottom). *) val map: ((Key.t * 'a) -> 'b) -> 'a t -> 'b t (** Use [optmap f q] to obtain a new heap by applying the mapping function [f] to the key and the value of every element in priority queue [q] to obtain a mapped element with the same key and a new value. The elements of [q] are visited in an arbitrary order (not top to bottom). When [f] returns [None] for a given key, that key will not be present in the new queue. *) val optmap: ((Key.t * 'a) -> 'b option) -> 'a t -> 'b t (** Use [partition f q] to obtain a pair of new priority queues that are the result of applying the partitioning function [f] to each element in the queue [q] in an arbitrary order (not top to bottom). The first queue returned will contain all the elements for which [f pair] returned true, and the second queue will return all the remaining elements. *) val partition: ((Key.t * 'a) -> bool) -> 'a t -> 'a t * 'a t (** Use [of_seq z] to construct a priority queue from a sequence of elements. Evaluates the whole sequence. *) val of_seq: (Key.t * 'a) Cf_seq.t -> 'a t (** Use [of_list s] to construct a priority queue from a list of elements. *) val of_list: (Key.t * 'a) list -> 'a t (** Use [to_seq q] to produce a sequence of elements in top to bottom order from the priority queue [q]. *) val to_seq: 'a t -> (Key.t * 'a) Cf_seq.t (** Use [to_seq2 q] to produce a sequence of elements from the priority queue [q], where the first element of each pair is a key-value pair obtained from the head of the queue, and the second element of the pair is the corresponding tail of the queue. *) val to_seq2: 'a t -> ((Key.t * 'a) * 'a t) Cf_seq.t end (*--- End of File [ cf_pqueue.mli ] ---*) cf-0.10/cf_rbtree.ml0000644000175000017500000006470010645470613014220 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_rbtree.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) type 'a node = | R of 'a * 'a node * 'a node | B of 'a * 'a node * 'a node | Z module type Node_T = sig module Key: Cf_ordered.Total_T type +'a t val cons: Key.t -> 'a -> 'a t val key: 'a t -> Key.t val obj: 'a t -> 'a val kcompare: Key.t -> 'a t -> int val compare: 'a t -> 'a t -> int end module Core(N: Node_T) = struct module N = N (* type 'a ic = IC_o | IC_l of 'a N.t | IC_r of 'a N.t let invariant_key_compare_ x = function | IC_o -> () | IC_r y when N.compare x y > 0 -> () | IC_l y when N.compare x y < 0 -> () | _ -> failwith "key out of order" let invariant_print_aux_ = let rec loop (ic : 'a ic) = function | Z -> Format.printf "Z@\n"; 0 | R (_, R (_, _, _), _) -> Format.printf "@[<2>R@\nR@\n"; failwith "red node has red child" | R (x, a, R (_, _, _)) -> Format.printf "@[<2>R@\n"; let _ = loop (IC_l x) a in Format.printf "R@\n"; failwith "red node has red child" | R (x, a, b) -> Format.printf "@[<2>R@\n"; invariant_key_compare_ x ic; let a = loop (IC_l x) a in let b = loop (IC_r x) b in Format.printf "a=%d,b=%d@]@\n" a b; begin match a, b with | h1, h2 when h1 = h2 -> h1 | _ -> failwith "imbalanced black height" end | B (x, a, b) -> Format.printf "@[<2>B@\n"; invariant_key_compare_ x ic; let a = loop (IC_l x) a in let b = loop (IC_r x) b in Format.printf "a=%d,b=%d@]@\n" a b; begin match a, b with | h1, h2 when h1 = h2 -> h1 + 1 | _ -> failwith "imbalanced black height" end in fun u -> Format.printf "| >invariant:@\n @[<2>"; match try `Okay (loop IC_o u) with x -> `Error x with | `Okay h -> Format.printf "@]@\n| Format.printf "!!!@."; flush stdout; raise x let invariant_noprint_aux_ = let rec loop = function | Z -> 0 | R (_, R (_, _, _), _) | R (_, _, R (_, _, _)) -> failwith "red node with red child" | R (_, a, b) -> begin match loop a, loop b with | h1, h2 when h1 = h2 -> h1 | _ -> failwith "imbalanced black height" end | B (_, a, b) -> begin match loop a, loop b with | h1, h2 when h1 = h2 -> h1 + 1 | _ -> failwith "imbalanced black height" end in fun u -> try ignore (loop u); true with Failure _ -> false (* ignore (loop u); true *) (* try ignore (loop u); true with Failure _ as x -> false *) let invariant_aux_ = invariant_noprint_aux_ *) let nil = Z let empty = function Z -> true | _ -> false let rec size = function | Z -> 0 | R (_, a, b) | B (_, a, b) -> succ (size a + size b) let rec min = function | Z -> raise Not_found | R (x, Z, _) | B (x, Z, _) -> x | R (_, y, _) | B (_, y, _) -> min y let rec max = function | Z -> raise Not_found | R (x, _, Z) | B (x, _, Z) -> x | R (_, _, y) | B (_, _, y) -> max y let rec search key = function | Z -> raise Not_found | (R (n, a, b) | B (n, a, b)) -> let d = N.kcompare key n in if d = 0 then n else search key (if d < 0 then a else b) let rec member key = function | Z -> false | (R (n, a, b) | B (n, a, b)) -> let d = N.kcompare key n in if d = 0 then true else member key (if d < 0 then a else b) let l_balance_ z n1 n2 = match n1, n2 with | R (y, R (x, a, b), c), d | R (x, a, R (y, b, c)), d -> R (y, B (x, a, b), B (z, c, d)) | _ -> B (z, n1, n2) let r_balance_ z n1 n2 = match n1, n2 with | a, R (y, b, R (x, c, d)) | a, R (x, R (y, b, c), d) -> R (y, B (z, a, b), B (x, c, d)) | _ -> B (z, n1, n2) let rec replace_aux_ x = function | Z -> R (x, Z, Z) | R (y, a, b) -> let d = N.compare x y in if d < 0 then R (y, replace_aux_ x a, b) else if d > 0 then R (y, a, replace_aux_ x b) else R (x, a, b) | B (y, a, b) -> let d = N.compare x y in if d < 0 then l_balance_ y (replace_aux_ x a) b else if d > 0 then r_balance_ y a (replace_aux_ x b) else B (x, a, b) let force_black_ = function | R (n, a, b) -> B (n, a, b) | u -> u let replace x u = let u = force_black_ (replace_aux_ x u) in (* assert (invariant_aux_ u); *) u let l_repair_ = function | R (x, B (y, a, b), c) -> l_balance_ x (R (y, a, b)) c, false | B (x, B (y, a, b), c) -> l_balance_ x (R (y, a, b)) c, true | B (x, R (y, a, B (z, b, c)), d) -> B (y, a, l_balance_ x (R (z, b, c)) d), false | _ -> assert (not true); Z, false let r_repair_ = function | R (x, a, B (y, b, c)) -> r_balance_ x a (R (y, b, c)), false | B (x, a, B (y, b, c)) -> r_balance_ x a (R (y, b, c)), true | B (x, a, R (y, B (z, b, c), d)) -> B (y, r_balance_ x a (R (z, b, c)), d), false | _ -> assert (not true); Z, false let dup_color_ x a b = function | Z -> assert (not true); R (x, a, b) | R _ -> R (x, a, b) | B _ -> B (x, a, b) let rec extract_min_ = function | Z | B (_, Z, B _) -> assert (not true); extract_min_ Z | B (x, Z, Z) -> Z, x, true | B (x, Z, R (y, a, b)) -> B (y, a, b), x, false | R (x, Z, a) -> a, x, false | (R (x, a, b) | B (x, a, b)) as n -> let a, m, r = extract_min_ a in let n = dup_color_ x a b n in if r then let n, r = r_repair_ n in n, m, r else n, m, false let cons_r_ x a b = R (x, a, b) let cons_b_ x a b = B (x, a, b) let ifxz_r_ y a = a, false, y let ifxz_b_ y = function | R (z, a, b) -> B (z, a, b), false, y | u -> u, true, y let rec extract_aux_ k = function | Z -> raise Not_found | B (y, a, b) -> extract_aux_mirror_ cons_b_ ifxz_b_ k y a b | R (y, a, b) -> extract_aux_mirror_ cons_r_ ifxz_r_ k y a b and extract_aux_mirror_ cons ifxz k y a b = let d = N.kcompare k y in if d < 0 then begin let a, r, v = extract_aux_ k a in let n = cons y a b in let n, r = if r then r_repair_ n else n, false in n, r, v end else if d > 0 then begin let b, r, v = extract_aux_ k b in let n = cons y a b in let n, r = if r then l_repair_ n else n, false in n, r, v end else if b = Z then begin ifxz y a end else begin let b, z, d = extract_min_ b in let n = cons z a b in let n, r = if d then l_repair_ n else n, false in n, r, y end let ifdz_r_ a = a, false let ifdz_b_ = function R (z, a, b) -> B (z, a, b), false | u -> u, true let rec delete_aux_ k = function | Z -> raise Not_found | B (y, a, b) -> delete_aux_mirror_ cons_b_ ifdz_b_ k y a b | R (y, a, b) -> delete_aux_mirror_ cons_r_ ifdz_r_ k y a b and delete_aux_mirror_ cons ifdz k y a b = let d = N.kcompare k y in if d > 0 then begin let b, r = delete_aux_ k b in let n = cons y a b in if r then l_repair_ n else n, false end else if d < 0 then begin let a, r = delete_aux_ k a in let n = cons y a b in if r then r_repair_ n else n, false end else match b with | Z -> ifdz a | b -> let b, z, d = extract_min_ b in let n = cons z a b in if d then l_repair_ n else n, false let delete k u = try let u, _ = delete_aux_ k u in (* assert (invariant_aux_ u); *) u with | Not_found -> u let rec of_list_aux_ acc = function | hd :: tl -> of_list_aux_ (replace hd acc) tl | [] -> acc let of_list s = of_list_aux_ nil s let rec of_seq_aux_ acc seq = match Lazy.force seq with | Cf_seq.P (hd, tl) -> of_seq_aux_ (replace hd acc) tl | Cf_seq.Z -> acc let of_seq z = of_seq_aux_ nil z type 'a digit = | Y of 'a node * 'a | X of 'a node * 'a * 'a node * 'a let rec accum_incr_ n x = function | [] -> [ Y (n, x) ] | Y (m, y) :: t -> X (m, y, n, x) :: t | X (m, y, p, z) :: t -> Y (n, x) :: (accum_incr_ (B (y, m, p)) z t) let rec accum_decr_ n x = function | [] -> [ Y (n, x) ] | Y (m, y) :: t -> X (n, x, m, y) :: t | X (p, z, m, y) :: t -> Y (n, x) :: (accum_decr_ (B (y, p, m)) z t) let rec final_incr_ acc = function | [] -> acc | Y (m, y) :: t -> final_incr_ (B (y, m, acc)) t | X (m, y, p, z) :: t -> final_incr_ (B (y, m, R (z, p, acc))) t let rec final_decr_ acc = function | [] -> acc | Y (m, y) :: t -> final_decr_ (B (y, acc, m)) t | X (p, z, m, y) :: t -> final_decr_ (B (y, R (z, acc, p), m)) t let of_list_incr = let rec loop last acc = function | hd :: tl -> if N.compare last hd > 0 then of_list_aux_ (replace hd (final_incr_ Z acc)) tl else loop hd (accum_incr_ Z hd acc) tl | [] -> final_incr_ Z acc in function | [] -> Z | hd :: tl -> loop hd [ Y (Z, hd) ] tl let of_list_decr = let rec loop last acc = function | hd :: tl -> if N.compare last hd < 0 then of_list_aux_ (replace hd (final_decr_ Z acc)) tl else loop hd (accum_decr_ Z hd acc) tl | [] -> final_incr_ Z acc in function | [] -> Z | hd :: tl -> loop hd [ Y (Z, hd) ] tl let of_seq_incr = let rec loop last acc z = match Lazy.force z with | Cf_seq.P (hd, tl) -> if N.compare last hd > 0 then of_seq_aux_ (replace hd (final_incr_ Z acc)) tl else loop hd (accum_incr_ Z hd acc) tl | Cf_seq.Z -> final_incr_ Z acc in fun z -> match Lazy.force z with | Cf_seq.Z -> Z | Cf_seq.P (hd, tl) -> loop hd [ Y (Z, hd) ] tl let of_seq_decr = let rec loop last acc z = match Lazy.force z with | Cf_seq.P (hd, tl) -> if N.compare last hd < 0 then of_seq_aux_ (replace hd (final_decr_ Z acc)) tl else loop hd (accum_decr_ Z hd acc) tl | Cf_seq.Z -> final_decr_ Z acc in fun z -> match Lazy.force z with | Cf_seq.Z -> Z | Cf_seq.P (hd, tl) -> loop hd [ Y (Z, hd) ] tl type 'a stack = ('a * 'a node) list let rec stack_min_ i = function | Z -> i | R (e, a, b) | B (e, a, b) -> stack_min_ ((e, b) :: i) a let rec stack_max_ i = function | Z -> i | R (e, a, b) | B (e, a, b) -> stack_max_ ((e, a) :: i) b let to_list_aux_ = let rec loop f acc = function | (e, s) :: tl -> let tl = match s with Z -> tl | _ -> f tl s in loop f (e :: acc) tl | [] -> acc (* reversed *) in fun f g u -> loop f [] (f g u) let to_list_incr u = to_list_aux_ stack_max_ [] u let to_list_decr u = to_list_aux_ stack_min_ [] u let to_seq_aux_ = let rec loop f = function | (e, s) :: tl -> let tl = match s with Z -> tl | _ -> f tl s in Cf_seq.P (e, lazy (loop f tl)) | [] -> Cf_seq.Z in fun f g u -> lazy (loop f (f g u)) let to_seq_incr u = to_seq_aux_ stack_min_ [] u let to_seq_decr u = to_seq_aux_ stack_max_ [] u let rec nearest_incr_aux_ key w = function | Z -> to_seq_aux_ stack_min_ w Z | R (n, a, b) | B (n, a, b) -> let d = N.kcompare key n in if d = 0 then lazy (Cf_seq.P (n, to_seq_aux_ stack_min_ w b)) else let w, n = if d < 0 then (n, b) :: w, a else w, b in nearest_incr_aux_ key w n let rec nearest_decr_aux_ key w = function | Z -> to_seq_aux_ stack_max_ w Z | R (n, a, b) | B (n, a, b) -> let d = N.kcompare key n in if d = 0 then lazy (Cf_seq.P (n, to_seq_aux_ stack_max_ w a)) else let w, n = if d > 0 then (n, a) :: w, b else w, a in nearest_decr_aux_ key w n let nearest_incr key u = nearest_incr_aux_ key [] u let nearest_decr key u = nearest_decr_aux_ key [] u let rec iterate f = function | Z -> () | B (n, a, b) | R (n, b, a) -> f n; iterate f a; iterate f b let rec predicate f = function | Z -> true | B (n, a, b) | R (n, b, a) -> f n && predicate f a && predicate f b let rec fold f x = function | Z -> x | B (n, a, b) | R (n, b, a) -> fold f (fold f (f x n) a) b let rec filter_aux_ v f = function | Z -> v | B (n, a, b) | R (n, b, a) -> let v = if f n then replace n v else v in filter_aux_ (filter_aux_ v f a) f b let filter f u = filter_aux_ Z f u let rec map f = function | Z -> Z | R (n, a, b) -> R (N.cons (N.key n) (f n), map f a, map f b) | B (n, a, b) -> B (N.cons (N.key n) (f n), map f a, map f b) let rec optmap_aux_ v f = function | Z -> v | B (n, a, b) | R (n, b, a) -> let v = match f n with | Some n' -> replace (N.cons (N.key n) n') v | None -> v in optmap_aux_ (optmap_aux_ v f a) f b let optmap f u = optmap_aux_ Z f u let rec partition_aux_ (v1, v2 as v) f = function | Z -> v | B (n, a, b) | R (n, b, a) -> let v = if f n then replace n v1, v2 else v1, replace n v2 in partition_aux_ (partition_aux_ v f a) f b let partition f u = partition_aux_ (Z, Z) f u end module Set(E: Cf_ordered.Total_T): (Cf_set.T with module Element = E) = struct include Core(struct module Key = E type 'a t = E.t let cons k _ = k let key k = k let obj v = assert (not true); Obj.magic v let kcompare x y = E.compare x y let compare x y = E.compare x y end) module Element = E type t = E.t node let put = replace let clear = delete let singleton x = replace x nil let compare s0 s1 = Cf_seq.fcmp E.compare (to_seq_incr s0) (to_seq_incr s1) let put_swap_ s x = replace x s let clear_swap_ s x = delete x s let member_swap_ s x = member x s (*--- The [diff], [intersect] and [union] functions may be more efficient if implemented more like the functions in the standard OCaml library [Set] module. The key function there is [join], which would have to be rewritten for red-black trees. The [split] and [concat] functions are implemented on top of [join]. The [diff], [intersect] and [union] functions are implemented on top of [join], [split] and [concat]. If [join] is fast enough on RB-trees, then our efficiency should compare well with the standard library. Hint: implement [join_aux_ ltree lheight v rheight rtree] and assume that [lheight] is the black-height of the [ltree] node and [rheight] is the black-height of the [rtree] node; then implement [join] as a wrapper on [join_aux_] that first computes the black-hight of [ltree] and [rtree]. ---*) let union s0 s1 = fold put_swap_ s0 s1 let diff s0 s1 = fold clear_swap_ s0 s1 let intersect s0 s1 = filter (member_swap_ s0) s1 let rec subset s1 s2 = match s1, s2 with | Z, _ -> true | _, Z -> false | (R (x1, a1, b1) | (B (x1, a1, b1))), (R (x2, a2, b2) | (B (x2, a2, b2))) -> let dx = E.compare x1 x2 in if dx = 0 then subset a1 a2 && subset b1 b2 else if dx < 0 then subset (B (x1, a1, Z)) a2 && subset b1 s2 else subset (B (x1, Z, b1)) b2 && subset a1 s2 (* this code was an aborted attempt at improving performance. it didn't seem to work, but that *may* have been the benchmark i was using, so i'm not in a big hurry to delete it just yet. (**) let rec log2_aux_ v n = if n > 1 then log2_aux_ (v + 1) (n lsr 1) else v let log2_ n = log2_aux_ 0 n let paint_black_ = function | R (x, a, b) -> B (x, a, b) | u -> u let rec height_ acc = function | Z -> acc | R (_, a, _) -> height_ acc a | B (_, a, _) -> height_ (succ acc) a let rec join_ x a b ah bh = match a, b with | Z, y | y, Z -> let y = replace x y in height_ 0 y, y | _, _ -> let dh = bh - ah in if dh < 0 then begin let bh', bx, ba, bb = match b with | Z -> assert (not true); bh, x, a, b | R (x, a, b) -> bh, x, a, b | B (x, a, b) -> pred bh, x, a, b in let ah', ba = join_ x a ba ah bh' in join_ bx ba bb ah' bh' end else begin assert (dh = 0); succ ah, B (x, a, b) end let rec build_dn_ n z = assert (n > 0); match Lazy.force z with | Cf_seq.Z -> 0, Z, z | Cf_seq.P (x, z) when n = 1 -> 1, B (x, Z, Z), z | _ -> let n = pred n in let ah, a, z = build_dn_ n z in match Lazy.force z with | Cf_seq.Z -> ah, a, z | Cf_seq.P (x, z) -> let bh, b, z = build_dn_ n z in let h, u = join_ x a b ah bh in h, u, z let rec build_up_ ah a n z = match Lazy.force z with | Cf_seq.Z -> ah, a, z | Cf_seq.P (x, z) when n = 0 && a = Z -> assert (ah = 0); build_up_ 1 (B (x, Z, Z)) (succ n) z | Cf_seq.P (x, z) -> let bh, b, z = build_dn_ n z in let h, a = join_ x a b ah bh in build_up_ h a (succ n) z let build_ z = let _, u, z = build_up_ 0 Z 0 z in assert (Cf_seq.Z = Lazy.force z); (* let u = paint_black_ u in *) (* assert (invariant_aux_ u); *) u let rec union_seq_ z1 z2 = lazy begin match Lazy.force z1, Lazy.force z2 with | Cf_seq.Z, Cf_seq.Z -> Cf_seq.Z | Cf_seq.Z, z | z, Cf_seq.Z -> z | Cf_seq.P (hd1, tl1), Cf_seq.P (hd2, tl2) -> let dx = E.compare hd1 hd2 in if dx = 0 then Cf_seq.P (hd1, union_seq_ tl1 tl2) else if dx < 0 then Cf_seq.P (hd1, union_seq_ tl1 z2) else Cf_seq.P (hd2, union_seq_ z1 tl2) end let union s1 s2 = let z1 = to_seq_incr s1 and z2 = to_seq_incr s2 in build_ (union_seq_ z1 z2) let rec intersect_seq_ z1 z2 = lazy begin match Lazy.force z1, Lazy.force z2 with | Cf_seq.Z, Cf_seq.Z -> Cf_seq.Z | Cf_seq.Z, z | z, Cf_seq.Z -> z | Cf_seq.P (hd1, tl1), Cf_seq.P (hd2, tl2) -> let dx = E.compare hd1 hd2 in if dx = 0 then Cf_seq.P (hd1, intersect_seq_ tl1 tl2) else if dx < 0 then Lazy.force (intersect_seq_ tl1 z2) else Lazy.force (intersect_seq_ z1 tl2) end let intersect s1 s2 = let z1 = to_seq_incr s1 and z2 = to_seq_incr s2 in build_ (intersect_seq_ z1 z2) let rec diff_seq_ z1 z2 = lazy begin match Lazy.force z1, Lazy.force z2 with | Cf_seq.Z, Cf_seq.Z -> Cf_seq.Z | Cf_seq.Z, z | z, Cf_seq.Z -> z | Cf_seq.P (hd1, tl1), Cf_seq.P (hd2, tl2) -> let dx = E.compare hd1 hd2 in if dx = 0 then Lazy.force (diff_seq_ tl1 tl2) else if dx < 0 then Cf_seq.P (hd1, diff_seq_ tl1 z2) else Lazy.force (diff_seq_ z1 tl2) end let diff s1 s2 = let z1 = to_seq_incr s1 and z2 = to_seq_incr s2 in build_ (diff_seq_ z1 z2) *) end module Map(K: Cf_ordered.Total_T) = struct include Core(struct module Key = K type 'a t = Key.t * 'a let cons k v = k, v let key (k, _) = k let obj (_, v) = v let kcompare x (y, _) = Key.compare x y let compare (x, _) (y, _) = Key.compare x y end) module Key = K type 'a t = 'a N.t node let search key u = N.obj (search key u) let extract k u = let u, _, v = extract_aux_ k u in (* assert (invariant_aux_ u); *) N.obj v, u let rec insert_aux_ x = function | Z -> R (x, Z, Z), None | R (y, a, b) -> let d = N.compare x y in if d < 0 then begin let a, xopt = insert_aux_ x a in R (y, a, b), xopt end else if d > 0 then begin let b, xopt = insert_aux_ x b in R (y, a, b), xopt end else begin let _, y = y in R (x, a, b), Some y end | B (y, a, b) -> let d = N.compare x y in if d < 0 then begin let a, xopt = insert_aux_ x a in l_balance_ y a b, xopt end else if d > 0 then begin let b, xopt = insert_aux_ x b in r_balance_ y a b, xopt end else begin let _, y = y in R (x, a, b), Some y end let insert x u = let u, xopt = insert_aux_ x u in let u = force_black_ u in (* assert (invariant_aux_ u); *) u, xopt let rec modify key f = function | Z -> raise Not_found | (B (x, a, b) | R (x, a, b)) as u -> let d = N.kcompare key x in if d < 0 then dup_color_ x (modify key f a) b u else if d > 0 then dup_color_ x a (modify key f b) u else dup_color_ (N.cons key (f (N.obj x))) a b u end (*--- End of File [ cf_rbtree.ml ] ---*) cf-0.10/cf_rbtree.mli0000644000175000017500000000466310433520572014366 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_rbtree.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** Functional red-black binary trees. *) (** {6 Overview} This module implements functional sets and maps based on red-black binary trees. This permits trees that can be used as an alternative to the [Set] and [Map] modules in the Ocaml standard library. For many operations on sets and maps, red-black binary trees give better performance that the balanced trees in the standard library (though some applications may see better performance with the standard modules). *) (** {6 Module} *) (** A functor that produces a module of type [Cf_set] to represent sets with the element type described by [E]. *) module Set(E: Cf_ordered.Total_T): Cf_set.T with module Element = E (** A functor that produces a module of type [Cf_map] to represent maps with keys of the type described by [K]. *) module Map(K: Cf_ordered.Total_T): Cf_map.T with module Key = K (*--- End of File [ cf_rbtree.mli ] ---*) cf-0.10/cf_regex.ml0000644000175000017500000002310710433520572014036 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_regex.ml Copyright (c) 2005-2006, 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. *---------------------------------------------------------------------------*) module Symbol = struct type t = char and 'a map = 'a array let map f = Array.init 256 (fun n -> f (char_of_int n)) let get m c = Array.unsafe_get m (int_of_char c) end module DFA = Cf_dfa.Create(Symbol) exception Error of string module P = Cf_parser open P.Op open DFA.Op let p_digit_ = P.sat (function '0'..'9' -> true | _ -> false) >>= fun c -> ~:(Char.code c - 48) let p_hexdigit_ = let base_ c = if c >= 'a' then 87 else if c >= 'A' then 55 else 48 in P.sat begin function ('0'..'9' | 'a'..'f' | 'A'..'F') -> true | _ -> false end >>= fun c -> ~:(Char.code c - base_ c) let p_backtick_ = ?.'`' let p_any_ = P.sat (fun _ -> true) let esc_ch_list_ = let hexcode_ _ = p_hexdigit_ >>= fun a -> p_hexdigit_ >>= fun b -> ~:(Char.chr (a * 16 + b)) in let deccode_ chA = let a = Char.code chA - 48 in p_digit_ >>= fun b -> p_digit_ >>= fun c -> let code = a * 100 + b * 10 + c in if code > 255 then P.nil else ~:(Char.chr code) in let control_ _ = P.sat begin function | '@'..'_' | 'a'..'z' -> true | _ -> false end >>= fun c -> let n = Char.code c in let n = if n >= 97 then n - 96 else n - 64 in ~:(Char.chr n) in let newline_ _ = ~:('\x0A') in let tab_ _ = ~:('\x09') in let return_ _ = ~:('\x0D') in [ 'n', newline_; 't', tab_; 'r', return_; 'x', hexcode_; 'c', control_; '0', deccode_; '1', deccode_; '2', deccode_; '`', ( ~: ); ] let ch_class_ = let l_bracket = ?.'[' in let r_bracket = ?.']' in let hyphen = ?.'-' in let eq (c1 : char) (c2 : char) = (c1 = c2) in let raw_ch = P.sat (function '-' | ']' -> false | _ -> true) in let esc_ch = let mapF (ch, f) = ?.ch >>= f in let aux = P.alt (List.map mapF ((']', ( ~: )) :: esc_ch_list_)) in p_backtick_ >>= fun _ -> aux in let single_ch = P.alt [ esc_ch; raw_ch ] in let range: (char, char -> bool) P.t = single_ch >>= fun a -> hyphen >>= fun _ -> single_ch >>= fun b -> ~:(fun ch -> ch >= a && ch <= b) in let eqLift p = p >>= fun ch -> ~:(fun c -> c = ch) in let esc_set = let alpha = function 'A'..'Z' | 'a'..'z' -> true | _ -> false in let digit = function '0'..'9' -> true | _ -> false in let alnum ch = alpha ch || digit ch in let specifier = P.alt [ (?.'a' >>= fun _ -> ~:alpha); (?.'d' >>= fun _ -> ~:digit); (?.'i' >>= fun _ -> ~:alnum); ] in p_backtick_ >>= fun _ -> specifier in let single = P.alt (List.map eqLift [ esc_ch; raw_ch ]) in let hyphen_ch = P.tok (function '-' -> Some (eq '-') | _ -> None) in let atom0 = P.alt [ hyphen_ch; esc_set; range; single ] in let atomN = P.alt [ esc_set; range; single ] in let atomlist = let existF ch f = f ch in atom0 >>= fun hd -> ?*atomN >>= fun tl -> ~:(fun ch -> List.exists (existF ch) (hd :: tl)) in let negate = ?/(?.'^') >>= function None -> ~:false | _ -> ~:true in l_bracket >>= fun _ -> negate >>= fun _ -> atomlist >>= fun f -> r_bracket >>= fun _ -> ~:(!^f) let esc_expr_list_ = let meta_ ch = ~:(!:ch) in let alpha_ _ = ~:(!^(function 'A'..'Z' | 'a'..'z' -> true | _ -> false)) in let alnum_ _ = ~:begin !^begin function | '0'..'9' | 'A'..'Z' | 'a'..'z' -> true | _ -> false end end in let digit_ _ = ~:(!^(function '0'..'9' -> true | _ -> false)) in let sat_white_ x = function '\009'..'\013' | '\032' -> x | _ -> not x in let white_ _ = ~:(!^(sat_white_ true)) in let nonwhite_ _ = ~:(!^(sat_white_ false)) in [ 'a', alpha_; 'i', alnum_; 'd', digit_; 's', white_; 'w', nonwhite_; '.', meta_; '?', meta_; '*', meta_; '+', meta_; '(', meta_; ')', meta_; '|', meta_; '[', meta_; ']', meta_; '^', meta_; '$', meta_; ] let esc_expr_ = let p_escape_ fLst = p_backtick_ >>= fun _ -> P.alt (List.map (fun (ch, f) -> ?.ch >>= f) fLst) in let esc_chx_list_ = List.rev_map begin fun (c, f) -> c, fun x -> f x >>= fun y -> ~:(!:y) end esc_ch_list_ in p_escape_ (List.rev_append esc_chx_list_ esc_expr_list_) let expr_parse = let symbol = let f = function | '\x00'..'\x1f' | '?' | '*' | '+' | '(' | ')' | '|' | '\x7f'..'\xff' -> false | _ -> true in P.sat f >>= fun c -> ~:(!:c) in let dot = ?.'.' >>= fun _ -> ~:(!^(fun c -> c <> '\n')) in let star x = ?.'*' >>= fun _ -> ~:(!*x) in let plus x = ?.'+' >>= fun _ -> ~:(!+x) in let question x = ?.'?' >>= fun _ -> ~:(!?x) in let postfix x = P.alt [ star x; plus x; question x; ~:x ] in let rec expr _ = term () >>= fun x -> ?* (?.'|' >>= fun _ -> term ()) >>= fun y -> ~:(List.fold_left (fun x y -> x $| y) x y) and term () = ?+(factor () >>= postfix) >>= fun (hd, tl) -> ~:(List.fold_left (fun x y -> x $& y) hd tl) and factor () = P.alt [ group (); ch_class_; esc_expr_; dot; symbol ] and group () = ?.'(' >>= fun _ -> expr DFA.nil >>= fun x -> ?.')' >>= fun _ -> ~:x in expr DFA.nil let expr_of_seq z = match expr_parse z with | Some (v, _) -> v | _ -> raise (Error (Cf_seq.to_string z)) let expr_of_string s = expr_of_seq (Cf_seq.of_string s) let quote = let esc_ = [ '`'; '.'; '?'; '*'; '+'; '('; ')'; '|'; '['; ']'; '^'; '$' ] in let rec loop c = let w = Lazy.lazy_from_val (Cf_flow.Q loop) in match c with | _ when List.exists (fun c' -> c == c') esc_ -> let w = Lazy.lazy_from_val (Cf_flow.P (c, w)) in Cf_flow.P ('`', w) | _ -> Cf_flow.P (c, w) in Lazy.lazy_from_val (Cf_flow.Q loop) let unquote = let rec loop c = let w = Lazy.lazy_from_val (Cf_flow.Q loop) in match c with | '`' -> Cf_flow.Q begin fun c -> Cf_flow.P (c, Lazy.lazy_from_val (Cf_flow.Q loop)) end | _ -> Cf_flow.P (c, w) in Lazy.lazy_from_val (Cf_flow.Q loop) type t = int DFA.t let of_expression x = DFA.create (x $@ (fun n z -> Some (n, Cf_seq.shift n z))) let of_seq z = of_expression (expr_of_seq z) let of_string s = of_expression (expr_of_string s) let test r s = let z = Cf_seq.of_string s in match r z with | Some (n, _) when n = String.length s -> true | _ -> false let search = let rec loop r pos z = match r z with | Some (n, _) -> pos, n | None -> match p_any_ z with | Some (_, z) -> loop r (succ pos) z | None -> raise Not_found in fun r -> loop r 0 let rec separate r z = lazy begin try let pos, len = search r z in let s = Cf_seq.limit pos z in let z = Cf_seq.shift (pos + len) z in Cf_seq.P (s, separate r z) with | Not_found -> Cf_seq.P (z, Cf_seq.nil) end let split = let rec loop r s pos acc z = match try Some (search r z) with Not_found -> None with | Some (pos', len') -> let x = String.sub s pos pos' in let pos = pos + pos' + len' in let z = Cf_seq.shift (pos' + len') z in loop r s pos (x :: acc) z | None -> List.rev_append acc [ Cf_seq.to_string z ] in fun r s -> loop r s 0 [] (Cf_seq.of_string s) let parse r z = match r z with | Some (n, tl) -> Some (Cf_seq.to_string (Cf_seq.limit n z), tl) | None -> None let parsex r = P.to_extended (parse r) (*--- End of File [ cf_regex.ml ] ---*) cf-0.10/cf_regex.mli0000644000175000017500000001601410404616701014204 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_regex.mli Copyright (c) 2005-2006, 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. *---------------------------------------------------------------------------*) (** Regular expression parsing, search and matching. *) (** {6 Overview} This module implements regular expression parsing, search and matching in pure Objective Caml. The grammar for regular expressions is a little unconventional. Instead of using a backslash as the escape character, the backtick character is used instead. This makes it easy to write regular expressions in string literals. Use any of the following constructions in regular expressions: - [`n ] Matches LF ("newline") character. - [`t ] Matches TAB character. - [`r ] Matches RETURN character. - [`a ] Matches an alphabetical character. - [`d ] Matches a decimal digit character. - [`i ] Matches an alphanumerical character. - [`s ] Matches a TAB, LF, VT, FF, CR or SPACE (whitespace) character. - [`w ] Matches a character other than a whitespace character. - [`xNN ] Matches the character with hexadecimal code [NN]. - [`DDD ] Matches the character with decimal code [DDD], where DDD is a three digit number between [000] and [255]. - [`c_ ] Matches the control character corresponding to the subsequent printable character, e.g. [`cA] is CONTROL-A, and [`c\[] is ESCAPE. - [. ] Matches any character except newline. - [* ] (postfix) Matches the preceding expression, zero, one or several times in sequence. - [+ ] (postfix) Matches the preceding expression, one or several times in sequence. - [? ] (postfix) Matches the preceding expression once or not at all. - [[..] ] Character set. Ranges are denoted with ['-'], as in [[a-z]]. An initial ['^'], as in [[^0-9]], complements the set. Special characters in the character set syntax may be included in the set by escaping them with a backtick, e.g. [[`^```\]]] is a set containing three characters: the carat, the backtick and the right bracket characters. - [(..|..)] Alternatives. Matches one of the expressions between the parentheses, which are separated by vertical bar characters. - [`_ ] Escaped special character. The special characters are ['`'], ['.'], ['*'], ['+'], ['?'], ['('], ['|'], [')'], ['\[']. *) (** {6 Modules} *) (** The deterministic finite automata on octet character symbols. *) module DFA: Cf_dfa.T with type S.t = char (** {6 Exceptions} *) (** An error parsing the specified string as a regular expression. *) exception Error of string (** {6 Types} *) (** An abstract type representing a regular expression. *) type t (** {6 Functions} *) (** A parser combinator on character streams that recognizes a regular expression and produces a DFA expression for it. *) val expr_parse: (char, DFA.x) Cf_parser.t (** Use [expr_of_seq z] to evaluate the character sequence [z] as a regular expression and produce the corresponding DFA expression. Raises [Error] if the sequence is not a valid expression. *) val expr_of_seq: char Cf_seq.t -> DFA.x (** Use [expr_of_string s] to evaluate the string [s] as a regular expression and produce the corresponding DFA expression. Raises [Error] if the string is not a valid expression. *) val expr_of_string: string -> DFA.x (** A character flow that quotes all the special characters in the input so that the output may be used in a regular expression to match the input exactly. *) val quote: (char, char) Cf_flow.t (** A character flow that unquotes all the quoted special characters in the input so that the output may by used in a regular expression to match the specified pattern. *) val unquote: (char, char) Cf_flow.t (** Use [of_expression x] to produce a regular expression from the DFA expression [x]. *) val of_expression: DFA.x -> t (** Use [of_seq z] to ingest the whole character sequence [z], parse it and produce a regular expression. Raises [Error s] if the sequence is not a valid regular expression, with [s] containing the string composed of the characters in the sequence. *) val of_seq: char Cf_seq.t -> t (** Use [of_string s] to produce a regular expression from the string [s]. Raises [Error s] if the string is not a valid regular expression. *) val of_string: string -> t (** Use [test r s] to test whether the string [s] matches the regular expression [r]. *) val test: t -> string -> bool (** Use [search r z] to search the character sequence [z] for a pattern that matches the regular expression [r]. Returns [(pos, len)], where [pos] is the number of characters into the sequence where the matching sequence begins, and [len] is the number matching characters. *) val search: t -> char Cf_seq.t -> int * int (** Use [separate r z] to map the character sequence [z] into the sequence of sequences found between matches for the regular expression [r]. *) val separate: t -> char Cf_seq.t -> char Cf_seq.t Cf_seq.t (** Use [split r s] to produce a list of strings by searching [s] left to right for blocks of characters between patterns that match the regular expression [r]. *) val split: t -> string -> string list (** Use [parse r] to produce a parser that matches the input stream to the regular expression [r] and returns the corresponding string value. *) val parse: t -> (char, string) Cf_parser.t (** Use [parse r] to produce a parser that matches the input stream to the regular expression [r] and returns the corresponding string value. *) val parsex: t -> ('c, char, string) Cf_parser.X.t (*--- End of File [ cf_regex.mli ] ---*) cf-0.10/cf_sbheap.ml0000644000175000017500000001602110535673075014175 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_sbheap.ml Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) type 'a node_t = 'a tree_t list and 'a tree_t = N of int * 'a * 'a list * 'a node_t module type Node_T = sig module Key: Cf_ordered.Total_T type +'a t val compare: 'a t -> 'a t -> int end module Core(N: Node_T) = struct module N = N let nil = [] let empty h = (h = []) let rec size = function hd :: tl -> (size_tree_ hd + size tl) | [] -> 0 and size_tree_ (N (_, _, xs, ts)) = 1 + List.length xs + size ts let rank_ (N (r, _, _, _)) = r let root_ (N (_, x, _, _)) = x let link_ t1 t2 = let N (r, x1, xs1, c1) = t1 and N (_, x2, xs2, c2) = t2 in let r = succ r in if N.compare x1 x2 < 0 then N (r, x1, xs1, t2 :: c1) else N (r, x2, xs2, t1 :: c2) let skew_link_ x t1 t2 = let N (r, y, ys, c) = link_ t1 t2 in if N.compare x y < 0 then N (r, x, y :: ys, c) else N (r, y, x :: ys, c) let rec insert_tree_ t = function | [] -> [ t ] | hd :: tl as ts -> if rank_ t < rank_ hd then t :: ts else insert_tree_ (link_ t hd) tl let rec merge_trees_ ts1 ts2 = match ts1, ts2 with | _, [] -> ts1 | [], _ -> ts2 | t1 :: ts1', t2 :: ts2' -> if rank_ t1 < rank_ t2 then t1 :: merge_trees_ ts1' ts2 else if rank_ t2 < rank_ t1 then t2 :: merge_trees_ ts1 ts2' else insert_tree_ (link_ t1 t2) (merge_trees_ ts1' ts2') let normalize_ = function | [] -> [] | hd :: tl -> insert_tree_ hd tl let put x = function | t1 :: t2 :: tail as ts -> if rank_ t1 = rank_ t2 then skew_link_ x t1 t2 :: tail else N (0, x, [], []) :: ts | ts -> N (0, x, [], []) :: ts let merge ts1 ts2 = merge_trees_ (normalize_ ts1) (normalize_ ts2) let rec shift_tree_ = function | [] -> raise Not_found | x :: [] -> x | hd :: tl -> let hd' = shift_tree_ tl in let x = root_ hd and y = root_ hd' in if N.compare x y < 0 then hd else hd' let head ts = root_ (shift_tree_ ts) let rec remove_tree_ = function | [] -> raise Not_found | x :: [] -> x, [] | hd :: tl -> let hd', tl' = remove_tree_ tl in let x = root_ hd in let y = root_ hd' in if N.compare x y < 0 then hd, tl else hd', hd :: tl' let rec tail_loop_ ts = function | x :: xs' -> tail_loop_ (put x ts) xs' | [] -> ts let tail ts = let N (_, _, xs, ts1), ts2 = remove_tree_ ts in tail_loop_ (merge (List.rev ts1) ts2) xs let pop ts = try Some (head ts, tail ts) with Not_found -> None let rec iterate f = let sub (N (_, x, xs, ts)) = f x; List.iter f xs; iterate f ts in function | hd :: tl -> sub hd; iterate f tl | [] -> () let rec predicate f = let sub (N (_, x, xs, ts)) = f x && List.for_all f xs && predicate f ts in function | hd :: tl -> sub hd && predicate f tl | [] -> true let rec fold f = let sub x0 (N (_, x, xs, ts)) = let x0 = fold f x0 ts in let x0 = List.fold_left f x0 xs in f x0 x in fun x0 -> function | hd :: tl -> fold f (sub x0 hd) tl | [] -> x0 let filter f = let g h x = if f x then put x h else h in fun ts -> fold g nil ts let partition f = let g (h0, h1) x = if f x then put x h0, h1 else h0, put x h1 in fun ts -> fold g (nil, nil) ts let of_list = let rec loop acc = function | hd :: tl -> loop (put hd acc) tl | [] -> acc in fun z -> loop nil z let of_seq = let rec loop acc seq = match Lazy.force seq with | Cf_seq.P (hd, tl) -> loop (put hd acc) tl | Cf_seq.Z -> acc in fun seq -> loop nil seq let rec to_seq h = lazy begin try Cf_seq.P (head h, to_seq (tail h)) with | Not_found -> Cf_seq.Z end let rec to_seq2 h = lazy begin try let N (_, x, xs, ts1), ts2 = remove_tree_ h in let tl = tail_loop_ (merge (List.rev ts1) ts2) xs in Cf_seq.P ((x, tl), to_seq2 tl) with | Not_found -> Cf_seq.Z end end module Heap(E: Cf_ordered.Total_T) = struct include Core(struct module Key = E type 'a t = E.t let compare x y = E.compare x y end) module Element = E type t = E.t node_t end module PQueue(K: Cf_ordered.Total_T) = struct include Core(struct module Key = K type 'a t = Key.t * 'a let compare (x, _) (y, _) = Key.compare x y end) module Key = K type 'a t = 'a N.t node_t let map f = let g h (k, _ as x) = put (k, f x) h in fun ts -> fold g nil ts let optmap f = let g h (k, _ as x) = match f x with | Some x -> put (k, x) h | None -> h in fun ts -> fold g nil ts end (*--- End of File [ cf_sbheap.ml ] ---*) cf-0.10/cf_sbheap.mli0000644000175000017500000000445710433520572014346 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_sbheap.mli Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) (** Functional skew binomial heaps with O(1) merge. *) (** This module implements a bootstrapped functional skew binomial heap, which have O(1) cost in space and time for most operations, including [merge]. The underlying algorithm can be found in Chris Okasaki's {{:http://www.cs.cmu.edu/~rwh/theses/okasaki.pdf}Ph.D. thesis}. *) (** {6 Modules} *) (** A functor that produces a module of type [Cf_heap] to represent heaps with the element type described by [E]. *) module Heap(E: Cf_ordered.Total_T): Cf_heap.T with module Element = E (** A functor that produces a module of type [Cf_pqueue] to represent priority queues with keys of the type described by [K]. *) module PQueue(K: Cf_ordered.Total_T): Cf_pqueue.T with module Key = K (*--- End of File [ cf_sbheap.mli ] ---*) cf-0.10/cf_scan_parser.ml0000644000175000017500000000563410450665062015234 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_scan_parser.ml Copyright (c) 2004-2006, 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 next_: 'i Cf_seq.t = z method private virtual get: char method init = Scanf.Scanning.from_function (fun () -> self#get) method fini = next_ 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 inherit [char] scanner z method private get = match Lazy.force next_ with | Cf_seq.Z -> raise End_of_file | Cf_seq.P (hd, tl) -> next_ <- tl; hd end class ['cursor] lex_scanner_x z = object constraint 'cursor = char #Cf_parser.cursor inherit [char * 'cursor] scanner z method private get = match Lazy.force next_ 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 let scanfx fmt rf z = let ef _ = raise No_match in cscanf (new lex_scanner_x) ef fmt rf z (*--- End of File [ cf_scan_parser.ml ] ---*) cf-0.10/cf_scan_parser.mli0000644000175000017500000001016610621270453015375 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_scan_parser.mli Copyright (c) 2004-2006, 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_parser} 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 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, 'u, 'f -> 'o, 'f -> 'o, 'o) format6 -> '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, 'u, 'f -> 'o, 'f -> 'o, 'o) format6 -> 'f -> (char, 'o) Cf_parser.t (** Use [scanfx] in place of [scanf] to construct a parser with a cursor weaved into the input stream. *) val scanfx: ('f, Scanf.Scanning.scanbuf, 'u, 'f -> 'o, 'f -> 'o, 'o) format6 -> 'f -> (char #Cf_parser.cursor, char, 'o) Cf_parser.X.t (*--- End of File [ cf_scan_parser.mli ] ---*) cf-0.10/cf_scmonad.ml0000644000175000017500000000376610433520572014361 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_scmonad.ml Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) type ('s, 'x, 'a) t = ('s -> 'x, 'a) Cf_cmonad.t (* ('a -> 's -> 'x) -> 's -> 'x *) (* 's -> (('s * 'a) -> 'x) -> 'x *) module Op = struct let ( >>= ) m c s = m (fun a -> c a s) end let nil f s = f () s let return a f s = f a s let init x _ _ = x let cont c f x = c (f () x) let load f s = f s s let store s f _ = f () s let modify c f s = f () (c s) let field r f s = f (r s) s let down m s f = m (fun () -> f) s let lift = Op.( >>= ) (*--- End of File [ cf_scmonad.ml ] ---*) cf-0.10/cf_scmonad.mli0000644000175000017500000000754210433520572014526 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_scmonad.mli Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) (** The state-continuation monad and its operators. *) (** {6 Overview} The state-continuation monad is provided here purely for reference purposes. It may be helpful as an example of how to lift the continuation monad into more complex monads. *) (** {6 Types} *) (** The state-continuation monad. *) type ('s, 'x, 'a) t = ('s -> 'x, 'a) Cf_cmonad.t (** {6 Modules} *) (** The continuation monad: a function for passing intermediate results from continuation context to continuation context with an encapsulated state value at each stage. *) module Op: sig (** Use [m >>= f] to produce a monad that applies [f] to the result of evaluating [m]. *) val ( >>= ): ('s, 'x, 'a) t -> ('a -> ('s, 'x, 'b) t) -> ('s, 'x, 'b) t end (** {6 Operators} *) (** A monad that returns [unit] and performs no operation. *) val nil: ('s, 'x, unit) t (** Use [return a] to produce a monad that returns [a] as an intermediate result from the current continuation. *) val return: 'a -> ('s, 'x, 'a) t (** Use [init x] to produce a monad that discards the current intermediate result and returns [x] as the continuation context. *) val init: 'x -> ('s, 'x, 'a) t (** Use [cont f] to produce a monad that passes the calling continuation to the function [f] and returns the unit value as an intermediate result. *) val cont: ('x -> 'x) -> ('s, 'x, unit) t (** A monad that returns the encapsulate state as an intermediate result. *) val load: ('s, 'x, 's) t (** Use [store s] to produce a monad with [s] as the value of its encapsulated state. *) val store: 's -> ('s, 'x, unit) t (** Use [modify f] to produce a monad that applies [f] to the encapsulated state to obtain a new state value, and which returns the unit value as its intermediate result. *) val modify: ('s -> 's) -> ('s, 'x, unit) t (** Use [field f] to produce a monad that returns the result of applying [f] to the value of the encapsulated state. *) val field: ('s -> 'a) -> ('s, 'x, 'a) t (** Use [down m s] to produce a stateless continuation monad from a state-continuation monad and an initial state. *) val down: ('s, 'x, unit) t -> 's -> ('x, 's) Cf_cmonad.t (** Use [lift m] to lift a stateless continuation monad into a state-continuation monad. *) val lift: ('x, 'a) Cf_cmonad.t -> ('s, 'x, 'a) t (*--- End of File [ cf_scmonad.mli ] ---*) cf-0.10/cf_seq.ml0000644000175000017500000003162110450665121013513 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_seq.ml Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) type 'a t = 'a cell Lazy.t and 'a cell = P of 'a * 'a t | Z exception Empty let nil = Lazy.lazy_from_val Z let head s = match Lazy.force s with | P (hd, _) -> hd | Z -> raise Empty let tail s = match Lazy.force s with | P (_, tl) -> tl | Z -> raise Empty let rec concat s1 s2 = lazy begin match Lazy.force s1 with | P (hd, tl) -> P (hd, concat tl s2) | Z -> Lazy.force s2 end let rec flatten z = lazy begin match Lazy.force z with | Z -> Z | P (hd, tl) -> match Lazy.force hd with | P (hd2, tl2) -> P (hd2, flatten (lazy (P (tl2, tl)))) | Z -> Lazy.force (flatten tl) end let limit = let rec loop ?x n s = match Lazy.force s with | Z -> Z | P (hd, tl) when n > 0 -> P (hd, lazy (loop (pred n) tl)) | _ -> match x with | None -> Z | Some x -> raise x in fun ?x n s -> if n < 0 then invalid_arg "Cf_seq.limit: n < 0"; lazy (loop ?x n s) let shift = let rec loop n = function | P (_, tl) when n > 0 -> loop (pred n) (Lazy.force tl) | cell -> cell in fun n s -> if n < 0 then invalid_arg "Cf_seq.shift: n < 0"; lazy (loop n (Lazy.force s)) let rec sentinel x z = lazy begin match Lazy.force z with | Z -> raise x | P (hd, tl) -> P (hd, sentinel x tl) end let reverse = let rec loop stack = function | P (hd, tl) -> loop (hd :: stack) (Lazy.force tl) | Z -> stack in fun s -> loop [] (Lazy.force s) let length = let rec loop n = function | P (_, y) -> loop (succ n) (Lazy.force y) | Z -> n in fun s -> loop 0 (Lazy.force s) let rec unfold f x = lazy begin match f x with | Some (y, x) -> P (y, unfold f x) | None -> Z end let rec unfold2 f x = lazy begin match f x with | Some (_, x as y) -> P (y, unfold2 f x) | None -> Z end let rec iterate f s = match Lazy.force s with | P (hd, tl) -> f hd; iterate f tl | Z -> () let rec predicate f s = match Lazy.force s with | P (hd, tl) -> f hd && predicate f tl | Z -> true let rec constrain f s = lazy begin match Lazy.force s with | P (hd, tl) when f hd -> P (hd, constrain f tl) | _ -> Z end let search f = let rec loop n s = match Lazy.force s with | P (hd, tl) -> if f hd then n else loop (succ n) tl | Z -> n in fun s -> loop 0 s let rec fold f m s = match Lazy.force s with | P (hd, tl) -> fold f (f m hd) tl | Z -> m let filter = let rec loop f s = match Lazy.force s with | P (hd, tl) when f hd -> P (hd, lazy (loop f tl)) | P (_, tl) -> loop f tl | Z -> Z in fun f s -> lazy (loop f s) let rec map f s = lazy begin match Lazy.force s with | P (hd, tl) -> P (f hd, map f tl) | Z -> Z end let optmap = let rec loop f s = match Lazy.force s with | Z -> Z | P (hd, tl) -> match f hd with | Some y -> P (y, lazy (loop f tl)) | None -> loop f tl in fun f s -> lazy (loop f s) let listmap = let rec inner f cont = function | hd :: tl -> P (hd, lazy (inner f cont tl)) | [] -> outer f cont and outer f s = match Lazy.force s with | P (hd, tl) -> inner f tl (f hd) | Z -> Z in fun f s -> lazy (outer f s) let seqmap = let rec inner f cont s = match Lazy.force s with | P (hd, tl) -> P (hd, lazy (inner f cont tl)) | Z -> outer f cont and outer f s = match Lazy.force s with | P (hd, tl) -> inner f tl (f hd) | Z -> Z in fun f s -> lazy (outer f s) let partition f s = filter f s, filter (fun x -> not (f x)) s let rec fcmp f s0 s1 = match Lazy.force s0, Lazy.force s1 with | P (hd1, tl1), P (hd2, tl2) -> let d = f hd1 hd2 in if d <> 0 then d else fcmp f tl1 tl2 | P _, Z -> 1 | Z, P _ -> -1 | Z, Z -> 0 let cmp s0 s1 = fcmp Pervasives.compare s0 s1 let equal s0 s1 = cmp s0 s1 = 0 let rec first s = lazy begin match Lazy.force s with | P ((hd, _), tl) -> P (hd, first tl) | Z -> Z end let rec second s = lazy begin match Lazy.force s with | P ((_, hd), tl) -> P (hd, second tl) | Z -> Z end let split s = first s, second s let rec combine s0 s1 = lazy begin match Lazy.force s0, Lazy.force s1 with | P (hd1, tl1), P (hd2, tl2) -> P ((hd1, hd2), combine tl1 tl2) | _, _ -> Z end let rec iterate2 f s0 s1 = match Lazy.force s0, Lazy.force s1 with | P (hd1, tl1), P (hd2, tl2) -> f hd1 hd2; iterate2 f tl1 tl2 | _, _ -> () let rec predicate2 f s0 s1 = match Lazy.force s0, Lazy.force s1 with | P (hd1, tl1), P (hd2, tl2) -> f hd1 hd2 && predicate2 f tl1 tl2 | Z, Z -> true | _, _ -> false let rec constrain2 f s0 s1 = lazy begin match Lazy.force s0, Lazy.force s1 with | P (hd1, tl1), P (hd2, tl2) when f hd1 hd2 -> P ((hd1, hd2), constrain2 f tl1 tl2) | _, _ -> Z end let rec fold2 f m s0 s1 = match Lazy.force s0, Lazy.force s1 with | P (hd1, tl1), P (hd2, tl2) -> fold2 f (f m hd1 hd2) tl1 tl2 | _, _ -> m let filter2 = let rec loop f s1 s2 = match Lazy.force s1, Lazy.force s2 with | P (hd1, tl1), P (hd2, tl2) when f hd1 hd2 -> P ((hd1, hd2), lazy (loop f tl1 tl2)) | P (_, tl1), P (_, tl2) -> loop f tl1 tl2 | _, _ -> Z in fun f s1 s2 -> lazy (loop f s1 s2) let rec map2 f s1 s2 = lazy begin match Lazy.force s1, Lazy.force s2 with | P (hd1, tl1), P (hd2, tl2) -> P (f hd1 hd2, map2 f tl1 tl2) | _, _ -> Z end let optmap2 = let rec loop f s1 s2 = match Lazy.force s1, Lazy.force s2 with | P (hd1, tl1), P (hd2, tl2) -> begin match f hd1 hd2 with | Some y -> P (y, lazy (loop f tl1 tl2)) | None -> loop f tl1 tl2 end | _, _ -> Z in fun f s1 s2 -> lazy (loop f s1 s2) let listmap2 = let rec inner f c1 c2 = function | hd :: tl -> P (hd, lazy (inner f c1 c2 tl)) | [] -> outer f c1 c2 and outer f s1 s2 = match Lazy.force s1, Lazy.force s2 with | P (hd1, tl1), P (hd2, tl2) -> inner f tl1 tl2 (f hd1 hd2) | _, _ -> Z in fun f s1 s2 -> lazy (outer f s1 s2) let seqmap2 = let rec inner f c1 c2 s = match Lazy.force s with | P (hd, tl) -> P (hd, lazy (inner f c1 c2 tl)) | Z -> outer f c1 c2 and outer f s1 s2 = match Lazy.force s1, Lazy.force s2 with | P (hd1, tl1), P (hd2, tl2) -> inner f tl1 tl2 (f hd1 hd2) | _, _ -> Z in fun f s1 s2 -> lazy (outer f s1 s2) let rec of_channel c = lazy (try P (input_char c, of_channel c) with End_of_file -> Z) let of_substring s = let len = String.length s in let rec loop pos = let pos = succ pos in if pos < len then P (String.unsafe_get s pos, lazy (loop pos)) else Z in fun pos -> lazy (loop (pred pos)) let of_string s = of_substring s 0 let of_subarray a = let len = Array.length a in let rec loop pos = let pos = succ pos in if pos < len then P (Array.unsafe_get a pos, lazy (loop pos)) else Z in fun pos -> lazy (loop (pred pos)) let of_array a = of_subarray a 0 let rec of_function f = lazy (try P (f (), of_function f) with Not_found -> Z) let rec of_list = function | [] -> Lazy.lazy_from_val Z | hd :: tl -> lazy (P (hd, of_list tl)) let rec to_channel s c = match Lazy.force s with | P (hd, tl) -> output_char c hd; to_channel tl c | Z -> () let to_string = let rec loop b = function | P (hd, tl) -> Buffer.add_char b hd; loop b (Lazy.force tl) | Z -> () in fun s -> let b = Buffer.create 32 in loop b (Lazy.force s); Buffer.contents b let to_substring = let rec loop str pos stop = function | P (hd, tl) when pos < stop -> String.unsafe_set str pos hd; loop str (succ pos) stop (Lazy.force tl) | x -> x in fun s str pos len -> if pos < 0 then invalid_arg "Cf_seq.to_substring: pos < 0"; if pos + len > String.length str then invalid_arg "Cf_seq.to_substring: pos + len > String.length str"; lazy (loop str pos len (Lazy.force s)) let to_array = let f cr _ = match !cr with | Z -> assert false | P (hd, tl) -> cr := Lazy.force tl; hd in fun s -> let len = length s in match Lazy.force s with | P _ as cell -> Array.init len (f (ref cell)) | Z -> [| |] let to_subarray = let rec loop v pos stop = function | P (hd, tl) when pos < stop -> Array.unsafe_set v pos hd; loop v (succ pos) stop (Lazy.force tl) | x -> x in fun s v pos len -> if pos < 0 then invalid_arg "Cf_seq.to_subarray: pos < 0"; if pos + len > Array.length v then invalid_arg "Cf_seq.to_subarray: pos + len > Array.length v"; lazy (loop v pos len (Lazy.force s)) let to_list s = List.rev (reverse s) let rec to_buffer s b = match Lazy.force s with | P (hd, tl) -> Buffer.add_char b hd; to_buffer tl b | Z -> () let to_function s = let s0 = ref s in let rec loop () = match Lazy.force !s0 with | P (hd, tl) -> s0 := tl; hd | Z -> raise End_of_file in loop let finishC_ _ = Lazy.lazy_from_val Z let finishSC_ _ _ = Lazy.lazy_from_val Z let writeC o f = lazy (P (o, f ())) let evalC m = m finishC_ let writeSC o f s = lazy (P (o, f () s)) let evalSC m s = m finishSC_ s module S = struct open Cf_smonad open Op let accumulate = let rec loop stack seq = match Lazy.force seq with | P (hd, tl) -> hd >>= fun x -> loop (x :: stack) tl | Z -> return (List.rev stack) in fun s -> loop [] s let rec sequence s = match Lazy.force s with | P (hd, tl) -> hd >>= fun _ -> sequence tl | Z -> return () end module C = struct open Cf_cmonad open Op let accumulate = let rec loop stack seq = match Lazy.force seq with | P (hd, tl) -> hd >>= fun x -> loop (x :: stack) tl | Z -> return (List.rev stack) in fun s -> loop [] s let rec sequence s = match Lazy.force s with | P (hd, tl) -> hd >>= fun _ -> sequence tl | Z -> return () end module SC = struct open Cf_scmonad open Op let accumulate = let rec loop stack seq = match Lazy.force seq with | P (hd, tl) -> hd >>= fun x -> loop (x :: stack) tl | Z -> return (List.rev stack) in fun s -> loop [] s let rec sequence s = match Lazy.force s with | P (hd, tl) -> hd >>= fun _ -> sequence tl | Z -> return () end (*--- Snd of File [ cf_seq.ml ] ---*) cf-0.10/cf_seq.mli0000644000175000017500000004525410450665121013673 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_seq.mli Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) (** Lazily-evaluated sequences (functional streams). *) (** {6 Overview} *) (** This module implements a functional stream type. It's like the built-in list type, but the tail of every element in the list is lazily evaluated. This means it is possible to represent sequences of infinite length, and define functions that operate on sequences in a functional, rather than imperative mode. Many of the other modules in the [cf] library make extensive use of this type. The functions for manipulating static lists in the standard [List] library all have equivalents here in this module. Additionally, there are some convenient functions for converting structures with imperative interfaces into sequences that permit functional algorithms to be applied. *) (** {6 Types} *) (** A lazily-evaluated sequence. *) type 'a t = 'a cell Lazy.t and 'a cell = | P of 'a * 'a t (** Element of a sequence *) | Z (** End of sequence *) (** {6 Exceptions} *) (** Operation not possible on an empty list. *) exception Empty (** {6 Functions} *) (** An empty sequence. *) val nil: 'a t (** Returns the first element in the sequence. Raises [Empty] if the sequence has no elements, i.e. if the sequence is [Z]. *) val head: 'a t -> 'a (** Discards the first element in the sequence and returns the sequence of remaining elements. Raises [Empty] if the sequence has no elements, i.e. if the sequence is [Z]. *) val tail: 'a t -> 'a t (** [concat a b] returns the sequence of all the elements in [a] followed by all the elements in [b]. Adds a constant cost to the evaluation of every element in the resulting sequence prior to the start of elements from [b], so it may be worth considering the use of a {!Cf_deque} object in place of a [Cf_seq] object to avoid cost explosion. *) val concat: 'a t -> 'a t -> 'a t (** [flatten a] returns the sequence of all the elements in the sequence of sequences by concatenating them. *) val flatten: 'a t t -> 'a t (** [limit n s] returns the sequence of all the elements in [s], up to [n] elements in number and no more. Raises [Invalid_argument] if [n < 0]. If [?x] is provided, then the exception is raised if the sequence is evaluated past the limit. *) val limit: ?x:exn -> int -> 'a t -> 'a t (** [shift n s] returns the sequence of all the elements in [s] after the first [n] elements are discarded. Returns the empty sequence if [s] has fewer than [n] elements. *) val shift: int -> 'a t -> 'a t (** [sentinel x s] returns a sequence identical to [s] except that [x] is raised by evaluating to the end. This is intended for use in incremental sequence processing. *) val sentinel: exn -> 'a t -> 'a t (** [reverse s] evaluates the entire sequence and composes a list of the elements in reverse order. Tail recursive. *) val reverse: 'a t -> 'a list (** Evaluates the entire sequence and returns the number elements. *) val length: 'a t -> int (** [unfold f a] returns the sequence composed of the results of applying [f] according to the following rule: the first application of [f] is with [a] as the argument; if the result is [None] then the empty sequence is returned; else, the result is [Some (hd, tl)] and the sequence returned is composed of an element [hd] followed by the sequence produced by looping through applications of [f tl] until [None] is returned to signal the end of the sequence. The function is defined as follows: {[ let rec unfold f s = match f s with | Some (hd, tl) -> P (hd, lazy (unfold f tl)) | None -> Z ]} *) val unfold: ('b -> ('a * 'b) option) -> 'b -> 'a t (** [unfold2 f a] is like [unfold f a] above, except that the sequence returned has elements which are pairs of output values and the input values that correspond to them. The function is defined as follows: {[ let rec unfold2 f s = match f s with | Some (hd, tl) -> P ((hd, s), lazy (unfold2 f tl)) | None -> Z ]} *) val unfold2: ('b -> ('a * 'b) option) -> 'b -> ('a * 'b) t (** [iterate f s] evaluates the entire sequence [s], applying [f] to each element in order until the end of the sequence is reached. Tail recursive. *) val iterate: ('a -> unit) -> 'a t -> unit (** [predicate f s] evaluates as much of the sequence [s] as necessary to determine that every element satisfy the predicate function [f]. If any element produces a [false] result, then [false] is returned and the remainder of the sequence is not evaluated. Otherwise, the entire sequence is evaluated and [true] is returned. Tail recursive. *) val predicate: ('a -> bool) -> 'a t -> bool (** [constrain f s] evaluates the sequence [s] by applying [f] to each element while the result is [true]. The returned sequence is all the elements of [s] before the first element for which [f] returns false. Tail recursive. *) val constrain: ('a -> bool) -> 'a t -> 'a t (** [search f s] evaluates the sequence [s] until the result of applying [f] is [true] and returns the number of elements applied that resulted in a [false] result. Tail recursive. *) val search: ('a -> bool) -> 'a t -> int (** [fold f a s] is like [List.fold_left] and is the result of applying [f] to the elements in sequence, i.e. [f (... (f (f a b1) b2) ...) bn], where [b1], [b2] ... [bn] are the elements of the sequence. Evaluates the entire sequence [s] in a tail recursive loop. *) val fold: ('b -> 'a -> 'b) -> 'b -> 'a t -> 'b (** [filter f s] returns the sequence produced by applying [f] to every element of [s] and taking all the elements for which the result is [true]. The sequence returned evaluates [s] on demand. *) val filter: ('a -> bool) -> 'a t -> 'a t (** [map f s] returns the sequence produced by transforming every element in [s] by applying it to [f]. The sequence returned evaluates [s] on demand. *) val map: ('a -> 'b) -> 'a t -> 'b t (** [optmap f s] returns the sequence produced by applying [f] to every element of [s] and taking all the [Some a] results in order. The sequence returned evaluates [s] on demand. *) val optmap: ('a -> 'b option) -> 'a t -> 'b t (** [listmap f s] returns the sequence produced by applying [f] to every element of [s] and taking all the resulting lists of elements in order. The sequence returned evaluates [s] on demand. *) val listmap: ('a -> 'b list) -> 'a t -> 'b t (** [seqmap f s] returns the sequence produced by applying [f] to every element of [s] and taking all the resulting sequences of elements in order. The sequence returned evaluates [s] on demand. *) val seqmap: ('a -> 'b t) -> 'a t -> 'b t (** [partition f s] returns two sequences. The first is the sequence of elements in [s] for which applying [f] results in [true], and the second is the sequence of elements for which applying [f] results in [false]. *) val partition: ('a -> bool) -> 'a t -> 'a t * 'a t (** [fcmp f a b] compares two sequences by applying [f] to the elements of each sequence in turn until the result is non-zero, or the end of one or both sequences is reached. If the result of [f] is non-zero, then that is the value returned; otherwise, the value returned is an indication of which sequences have ended. If [a] ends while [b] continues, then the result is [1]. If [b] ends while [a] continues, then the result is [(-1)]. If both sequences end at the same place, then [0] is returned. The function is defined as follows: {[ let rec fcmp f s0 s1 = match s0, s1 with | P (x0, y0), P (x1, y1) -> let d = f x0 x1 in if d <> 0 then d else fcmp f (Lazy.force y0) (Lazy.force y1) | P _, Z -> 1 | Z, P _ -> -1 | Z, Z -> 0 ]} *) val fcmp: ('a -> 'a -> int) -> 'a t -> 'a t -> int (** [cmp a b] is the same as [fcmp Pervasives.compare a b]. *) val cmp: 'a t -> 'a t -> int (** [equal a b] returns [true], if every element in both sequences [a] and [b] are logically equivalent, as with the built-in [(=)] comparison operator. Both sequences are evaluated until one of the sequences reaches the end, or the elements in each are found to be inequivalent. *) val equal: 'a t -> 'a t -> bool (** [first s] returns the sequence of elements composed by taking only the first object in an element pair. Evaluates [s] on demand. *) val first: ('a * 'b) t -> 'a t (** [second s] returns the sequence of elements composed by taking only the second object in an element pair. Evaluates [s] on demand. *) val second: ('a * 'b) t -> 'b t (** [split s] is equivalent to [(first s, second s)]. *) val split: ('a * 'b) t -> 'a t * 'b t (** [combine a b] returns the sequence composed of the pairs of elements produced by combining each element from [a] and the corresponding element from [b] in a pair [(a, b)] until all the elements from one or both sequences are exhausted. The sequences [a] and [b] are evaluated on demand. The resulting sequence is only as long as the shorter of the two input sequences. *) val combine: 'a t -> 'b t -> ('a * 'b) t (** [iterate2 f a b] is like [iterate f s], except it operates on a pair of sequences simultaneously, until one or both sequences reaches its end. *) val iterate2: ('a -> 'b -> unit) -> 'a t -> 'b t -> unit (** [predicate2 f a b] is like [predicate f s], except it operates on a pair of sequences simultaneously, until one or both sequences reaches its end. If the sequences are not the same length, then the result is always [false]. *) val predicate2: ('a -> 'b -> bool) -> 'a t -> 'b t -> bool (** [constrain2 f a b] is like [constrain f s], except it operates on a pair of sequences simultaneously, until one or both sequences reaches its end or the constrain returns [false]. *) val constrain2: ('a -> 'b -> bool) -> 'a t -> 'b t -> ('a * 'b) t (** [fold2 f a s1 s2] is like [fold f a s], except it operates on a pair of sequences simultaneously, until one or both sequences reaches its end. *) val fold2: ('c -> 'a -> 'b -> 'c) -> 'c -> 'a t -> 'b t -> 'c (** [filter2 f a b] is like [filter f s], except it operates on a pair of sequences simultaneously, until one or both sequences reaches its end. *) val filter2: ('a -> 'b -> bool) -> 'a t -> 'b t -> ('a * 'b) t (** [map2 f a b] is like [map f s], except it operates on a pair of sequences simultaneously, until one or both sequences reaches its end. *) val map2: ('a -> 'b -> 'c) -> 'a t -> 'b t -> 'c t (** [optmap2 f a b] is like [optmap f s], except it operates on a pair of sequences simultaneously, until one or both sequences reaches its end. *) val optmap2: ('a -> 'b -> 'c option) -> 'a t -> 'b t -> 'c t (** [listmap2 f a b] is like [listmap f s], except it operates on a pair of sequences simultaneously, until one or both sequences reaches its end. *) val listmap2: ('a -> 'b -> 'c list) -> 'a t -> 'b t -> 'c t (** [seqmap2 f a b] is like [seqmap f s], except it operates on a pair of sequences simultaneously, until one or both sequences reaches its end. *) val seqmap2: ('a -> 'b -> 'c t) -> 'a t -> 'b t -> 'c t (** [of_channel c] returns the sequence of characters produced by reading them on demand from the channel [c]. (Note: this means that dueling [char t] sequences reading from the same [in_channel] object may interfere with one another.) The sequence returned ends when [EOF] happens on the channel. *) val of_channel: in_channel -> char t (** [of_string s] returns the sequence of characters produced by extracting them on demand from the string [s] with [String.unsafe_get]. Since the contents of strings are mutable, be advised that the character extracted from the string is determined at the time the position in the sequence is evaluated, and that subsequent changes to the string will not be reflected in the sequence. *) val of_string: string -> char t (** [of_substring s pos] returns the sequence of characters produced by extracting them on demand from the string [s] with [String.unsafe_get]. Returns [Invalid_argument] if [pos < 0] or [pos >= String.length s]. The sequence ends when the end of the string is reached. If a shorter substring is desired, use the [limit] function in conjunction. *) val of_substring: string -> int -> char t (** [of_array v] is like [of_string s], except that it operates on an ['a array] value instead of a [string] value. *) val of_array: 'a array -> 'a t (** [of_subarray v pos] is like [of_substring s pos], except that it operates on an ['a array] value instead of a [string] value. *) val of_subarray: 'a array -> int -> 'a t (** [of_list s] converts a ['a list] value into a sequence. *) val of_list: 'a list -> 'a t (** [of_function f] returns a sequence produced by applying [f ()] repeatedly until [Not_found] is raised. *) val of_function: (unit -> 'a) -> 'a t (** [to_channel s c] evaluates the entire character sequence [s] and puts each character produced into the [out_channel] object in a tail-recursive loop. *) val to_channel: char t -> out_channel -> unit (** [to_string s] evaluates the entire character sequence [s] and composes a [string] value containing the characters in order. Tail-recursive. *) val to_string: char t -> string (** [to_substring s str pos len] overwrites the substring of [str] starting at [pos] and running for [len] characters, with the first [len] characters from the sequence [s]. If the sequence is shorter than [len] characters, then the rest of the substring is not overwritten. If [pos] and [len] do not describe a valid substring of [str], then [Invalid_argument] is raised. The unused portion of the character sequence is returned. *) val to_substring: char t -> string -> int -> int -> char t (** [to_array v] is like [to_string s], except that it constructs an ['a array] value instead of a [string] value. *) val to_array: 'a t -> 'a array (** [to_subarray s v pos len] is like [to_substring s str pos len], except that it overwrites an ['a array] value instead of a [string] value. *) val to_subarray: 'a t -> 'a array -> int -> int -> 'a t (** [to_list s] is the same as [List.rev (reverse s)]. *) val to_list: 'a t -> 'a list (** [to_buffer s b] is like [to_channel s c] except that characters are output to a [Buffer] object, instead of an [out_channel] object. *) val to_buffer: char t -> Buffer.t -> unit (** [to_function s] returns a function that evaluates the next value in the sequence each time it's called. When the sequence completes, [End_of_file] is raised. *) val to_function: 'a t -> (unit -> 'a) (** {6 Monad Functions} *) (** Use [write x] to compose a continuation monad that puts [x] into the sequence produced by evaluation and returns the unit value. *) val writeC: 'x -> ('x t, unit) Cf_cmonad.t (** Use [evalC m] to evaluate the continuation monad [m] to compute the sequence it encapsulates. *) val evalC: ('x t, unit) Cf_cmonad.t -> 'x t (** Use [writeSC x] to compose a state-continuation monad that puts [x] into the sequence produced by evaluation and returns the unit value. *) val writeSC: 'x -> ('s, 'x t, unit) Cf_scmonad.t (** Use [evalSC m s] to evaluate the state-continuation monad [m] with the initial state [s], computing the encapsulated sequence. *) val evalSC: ('s, 'x t, unit) Cf_scmonad.t -> 's -> 'x t (** The module containing the [sequence] and [accumulate] functions for the state monad. *) module S: sig (** Use [sequence z] to compose a monad that binds all of the monads in the sequence [z] in the order specified. Returns the unit value. *) val sequence: ('x, unit) Cf_smonad.t t -> ('x, unit) Cf_smonad.t (** Use [accumulate z] to compose a monad that binds all of the monads in the sequence [z] in the order specified, accumulating all of the values returned into a list. *) val accumulate: ('x, 'a) Cf_smonad.t t -> ('x, 'a list) Cf_smonad.t end (** The module containing the [sequence] and [accumulate] functions for the continuation monad. *) module C: sig (** Use [sequence z] to compose a monad that binds all of the monads in the sequence [z] in the order specified. Returns the unit value. *) val sequence: ('x, unit) Cf_cmonad.t t -> ('x, unit) Cf_cmonad.t (** Use [accumulate z] to compose a monad that binds all of the monads in the sequence [z] in the order specified, accumulating all of the values returned into a list. *) val accumulate: ('x, 'a) Cf_cmonad.t t -> ('x, 'a list) Cf_cmonad.t end (** The module containing the [sequence] and [accumulate] functions for the state-continuation monad. *) module SC: sig (** Use [sequence z] to compose a monad that binds all of the monads in the sequence [z] in the order specified. Returns the unit value. *) val sequence: ('s, 'x, unit) Cf_scmonad.t t -> ('s, 'x, unit) Cf_scmonad.t (** Use [accumulate z] to compose a monad that binds all of the monads in the sequence [z] in the order specified, accumulating all of the values returned into a list. *) val accumulate: ('s, 'x, 'a) Cf_scmonad.t t -> ('s, 'x, 'a list) Cf_scmonad.t end (*--- End of File [ cf_seq.mli ] ---*) cf-0.10/cf_set.ml0000644000175000017500000000552710433520572013525 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_set.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) module type T = sig type t module Element: sig type t end val nil: t val empty: t -> bool val size: t -> int val member: Element.t -> t -> bool val singleton: Element.t -> t val min: t -> Element.t val max: t -> Element.t val put: Element.t -> t -> t val clear: Element.t -> t -> t val union: t -> t -> t val diff: t -> t -> t val intersect: t -> t -> t val compare: t -> t -> int val subset: t -> t -> bool val of_list: Element.t list -> t val of_list_incr: Element.t list -> t val of_list_decr: Element.t list -> t val of_seq: Element.t Cf_seq.t -> t val of_seq_incr: Element.t Cf_seq.t -> t val of_seq_decr: Element.t Cf_seq.t -> t val to_list_incr: t -> Element.t list val to_list_decr: t -> Element.t list val to_seq_incr: t -> Element.t Cf_seq.t val to_seq_decr: t -> Element.t Cf_seq.t val nearest_decr: Element.t -> t -> Element.t Cf_seq.t val nearest_incr: Element.t -> t -> Element.t Cf_seq.t val iterate: (Element.t -> unit) -> t -> unit val predicate: (Element.t -> bool) -> t -> bool val fold: ('a -> Element.t -> 'a) -> 'a -> t -> 'a val filter: (Element.t -> bool) -> t -> t val partition: (Element.t -> bool) -> t -> t * t end (*--- End of File [ cf_set.ml ] ---*) cf-0.10/cf_set.mli0000644000175000017500000002130610433520572013667 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_set.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** A module type for functional set implementations (with enhancements over the {!Set} module in the standard library). *) (** {6 Overview} This module defines the common interface to the various implementations of functional sets in the {!Cf} library. *) module type T = sig (** The set type *) type t (** A module defining the type of the element. Some set implementations may define more functions in this module for disambiguating keys from one another. *) module Element: sig type t end (** The empty set. *) val nil: t (** Use [empty s] to test whether the set [s] is the empty set. *) val empty: t -> bool (** Use [size s] to compute the size of the set [s]. *) val size: t -> int (** Use [member e s] to test whether the element [e] is a member of the set [s]. *) val member: Element.t -> t -> bool (** Use [singleton e] to compose a new set containing only the element [e]. *) val singleton: Element.t -> t (** Use [min s] to return the ordinally least element in the set [s]. Raises [Not_found] if the set is empty. *) val min: t -> Element.t (** Use [min s] to return the ordinally greatest element in the set [s]. Raises [Not_found] if the set is empty. *) val max: t -> Element.t (** Use [put e s] to obtain a new set produced by inserting the element [e] into the set [s]. If [s] already contains a member ordinally equal to [e] then it is replaced by [e] in the set returned. *) val put: Element.t -> t -> t (** Use [clear e s] to obtain a new set produced by deleting the element in the set [s] ordinally equal to the element [e]. If there is no such element in the set, then the set is returned unchanged. *) val clear: Element.t -> t -> t (** Use [union s1 s2] to obtain a new set from the union of the sets [s1] and [s2]. Elements of the new set belonging to the intersection are copied from [s2]. *) val union: t -> t -> t (** Use [diff s1 s2] to obtain a new set from the difference of the sets [s1] and [s2]. *) val diff: t -> t -> t (** Use [interset s1 s2] to obtain a new set from the intersection of the sets [s1] and [s2]. All the elements in the new set are copied from [s2]. *) val intersect: t -> t -> t (** Use [compare s1 s2] to compare the sequence of elements in the set [s1] and the sequence of elements in the set [s2] in order of increasing ordinality. Two sets are ordinally equal if the sequences of their elements are ordinally equal. *) val compare: t -> t -> int (** Use [subset s1 s2] to test whether the set [s1] is a subset of [s2]. *) val subset: t -> t -> bool (** Use [of_list s] to iterate a list of elements and compose a new set by inserting them in order. *) val of_list: Element.t list -> t (** Use [of_list_incr s] to compose the set with elements in the ordered list [s]. Runs in linear time if the list [s] is known to be in increasing order. Otherwise, there is an additional linear cost beyond [of_list s]. *) val of_list_incr: Element.t list -> t (** Use [of_list_decr s] to compose the set with elements in the ordered list [s]. Runs in linear time if the list [s] is known to be in decreasing order. Otherwise, there is an additional linear cost beyond [of_list s]. *) val of_list_decr: Element.t list -> t (** Use [of_seq z] to evaluate a sequence of elements and compose a new set by inserting them in order. *) val of_seq: Element.t Cf_seq.t -> t (** Use [of_seq_incr z] to compose the set with elements in the ordered sequence [z]. Runs in linear time if the sequence [z] is known to be in increasing order. Otherwise, there is an additional linear cost beyond [of_seq z]. *) val of_seq_incr: Element.t Cf_seq.t -> t (** Use [of_seq_decr z] to compose the set with elements in the ordered sequence [z]. Runs in linear time if the sequence [z] is known to be in decreasing order. Otherwise, there is an additional linear cost beyond [of_seq z]. *) val of_seq_decr: Element.t Cf_seq.t -> t (** Use [to_list_incr s] to produce the list of elements in the set [s] in order of increasing ordinality. *) val to_list_incr: t -> Element.t list (** Use [to_list_decr s] to produce the list of elements in the set [s] in order of decreasing ordinality. *) val to_list_decr: t -> Element.t list (** Use [to_seq_incr s] to produce the sequence of elements in the set [s] in order of increasing ordinality. *) val to_seq_incr: t -> Element.t Cf_seq.t (** Use [to_seq_decr s] to produce the sequence of elements in the set [s] in order of decreasing ordinality. *) val to_seq_decr: t -> Element.t Cf_seq.t (** Use [nearest_decr k s] to obtain the key-value pair ordinally less than or equal to the key [k] in the set [s]. Raises [Not_found] if the set is empty or all the keys are ordinally greater. *) val nearest_decr: Element.t -> t -> Element.t Cf_seq.t (** Use [nearest_incr k s] to obtain the element ordinally greater than or equal to the key [k] in the set [s]. Raises [Not_found] if the set is empty or all the keys are ordinally less. *) val nearest_incr: Element.t -> t -> Element.t Cf_seq.t (** Use [iterate f s] to apply the iterator function [f] to every element in the set [s] in arbitrary order (not increasing or decreasing). *) val iterate: (Element.t -> unit) -> t -> unit (** Use [predicate f s] to test whether all the elements in the set [s] satisfy the predicate function [f], visiting the elements in an arbitrary order (not increasing or decreasing) until [f] returns [false] or all elements are tested. *) val predicate: (Element.t -> bool) -> t -> bool (** Use [fold f a s] to fold the elements of the set [s] into the folding function [f] with the initial state [a], by applying the elements in an arbitrary order (not increasing or decreasing). *) val fold: ('a -> Element.t -> 'a) -> 'a -> t -> 'a (** Use [filter f s] to produce a new set comprised of all the elements of the set [s] that satisfy the filtering function [f], applying the elements in an arbitrary order (not increasing or decreasing). *) val filter: (Element.t -> bool) -> t -> t (** Use [partition f s] to produce two new sets by applying the partitioning function [f] to every element in the set [s] in an arbitrary order (not increasing or decreasing). The first set returned contains all the elements for which applying [f] returns [true]. The second set returned contains all the elements for which applying [f] returns [false]. *) val partition: (Element.t -> bool) -> t -> t * t end (*--- End of File [ cf_set.mli ] ---*) cf-0.10/cf_smonad.ml0000644000175000017500000000343510433520572014207 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_monad.ml Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) type ('s, 'a) t = 's -> 'a * 's module Op = struct let ( >>= ) m f s = let a, s = m s in f a s end let nil s = (), s let return a s = a, s let load s = s, s let store s _ = (), s let modify f s = (), (f s) let field f s = (f s), s (*--- End of File [ cf_monad.ml ] ---*) cf-0.10/cf_smonad.mli0000644000175000017500000000616610433520572014364 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_smonad.mli Copyright (c) 2002-2006, 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. *---------------------------------------------------------------------------*) (** The state monad and its operators. *) (** {6 Overview} The state monad is provided here mostly for reference purposes. It is not actually used directly within the [cf] library. However, it is sometimes helpful to have an example of the state monad to use when lifting another monad into a new monad with state. *) (** {6 Types} *) (** The state monad. Evaluate by calling it with an initial state. *) type ('s, 'a) t = 's -> 'a * 's (** {6 Modules } *) (** A module containing the [( >>= )] binding operator for composition of state monads. *) module Op: sig (** Use [m >>= f] to produce a monad that applies [f] to the result of evaluating [m]. *) val ( >>= ): ('s, 'a) t -> ('a -> ('s, 'b) t) -> ('s, 'b) t end (** {6 Operators} *) (** A monad that returns [unit] and performs no operation. *) val nil: ('s, unit) t (** Use [return a] to produce a monad that returns [a] when evaluated. *) val return: 'a -> ('s, 'a) t (** A monad that returns the encapsulate state. *) val load: ('s, 's) t (** Use [store s] to produce a monad with [s] as the value of its encapsulated state. *) val store: 's -> ('s, unit) t (** Use [modify f] to produce a monad that applies [f] to the encapsulated state to obtain a new state value, and which returns the unit value as its result when evaluated. *) val modify: ('s -> 's) -> ('s, unit) t (** Use [field f] to produce a monad that returns the result of applying [f] to the value of the encapsulated state. *) val field: ('s -> 'a) -> ('s, 'a) t (* let field f s = (f s), s *) (*--- End of File [ cf_smonad.mli ] ---*) cf-0.10/cf_sock_common.ml0000644000175000017500000001006110433520573015227 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_sock_common.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) class type endpoint = object method fd: Unix.file_descr method send: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int method recv: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int method shutdown: Unix.shutdown_command -> unit method close: unit end module type T = sig module P: Cf_socket.P type t = (P.AF.tag, P.ST.tag) Cf_socket.t type address = P.AF.address val create: unit -> t val createpair: unit -> t * t class basic: ?sock:t -> unit -> object val socket_: t method socket: t method fd: Unix.file_descr method close: unit method dup: t method dup2: t -> unit method getsockopt: ('a, P.AF.tag, P.ST.tag) Cf_socket.sockopt -> 'a method setsockopt: ('a, P.AF.tag, P.ST.tag) Cf_socket.sockopt -> 'a -> unit method private getsockname: address method private getpeername: address method private shutdown: Unix.shutdown_command -> unit method private bind: address -> unit end end module Create(P: Cf_socket.P) = struct module P = P type t = (P.AF.tag, P.ST.tag) Cf_socket.t type address = P.AF.address open Cf_socket let create () = create P.AF.domain P.ST.socktype P.protocol let createpair () = createpair P.AF.domain P.ST.socktype P.protocol class basic ?(sock = create ()) () = object val socket_ = sock method fd = to_unix_file_descr socket_ method socket = socket_ method dup = dup socket_ method dup2 s = dup2 socket_ s method close = close socket_ method getsockopt: 'a. ('a,P.AF.tag, P.ST.tag) Cf_socket.sockopt -> 'a = fun opt -> getsockopt socket_ opt method setsockopt: 'a. ('a,P.AF.tag, P.ST.tag) Cf_socket.sockopt -> 'a -> unit = fun opt x -> setsockopt socket_ opt x method private getsockname = P.AF.of_sockaddr (getsockname socket_) method private getpeername = P.AF.of_sockaddr (getpeername socket_) method private shutdown cmd = shutdown socket_ cmd method private bind addr = bind socket_ (P.AF.to_sockaddr addr) end end (*--- End of File [ cf_sock_common.ml ] ---*) cf-0.10/cf_sock_common.mli0000644000175000017500000001557510433520573015417 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_sock_common.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** Object-oriented interface to extended network sockets interface. An alternative to the imperative functions interface described above is the object-oriented interface. With the object-oriented interface, type constraints guard against more opportunities for runtime exceptions, but the API is substantially different from the Berkeley sockets API. *) (** The class type of network endpoints, i.e. objects containing socket descriptors and the specific methods they support. *) class type endpoint = object (** Returns the [Unix.file_descr] equivalent of the socket descriptor. *) method fd: Unix.file_descr (** Use [obj#send ?flags buf pos len] to send [len] octets from the string [buf] starting at position [pos], optionally with the flags indicated by [flags]. Returns the number of octets actually sent. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) method send: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int (** Use [obj#recv ?flags buf pos len] to receive [len] octets to the string [buf] starting at position [pos], optionally with the flags indicated by [flags]. Returns the number of octets actually received. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) method recv: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int (** Use [obj#shutdown cmd] to shutdown either sending or receiving (or both) on the socket. Raises [Unix.Error] if there is an error. *) method shutdown: Unix.shutdown_command -> unit (** Use [obj#close] to close the socket. Raises [Unix.Error] if there is an error. *) method close: unit end (** The type of module created by the Create(P: P) functor. *) module type T = sig (** The module input for the Create(P: Cf_socket.P) functor *) module P: Cf_socket.P (** The specialized socket type. *) type t = (P.AF.tag, P.ST.tag) Cf_socket.t (** The specialized address type. *) type address = P.AF.address (** Use [create ()] to create a new socket. Raises [Unix.Error] if there is an error. *) val create: unit -> t (** Use [createpair ()] to create a pair of new sockets that are connected to one another. Raises [Unix.Error] if there is an error. *) val createpair: unit -> t * t (** The base class for all sockets of this protocol. Use [inherit basic ?sock ()] to derive a new class. If [sock] is not provided, then a new socket is created, raising [Unix.Error] if an error is encountered. *) class basic: ?sock:t -> unit -> object val socket_: t (** The socket *) (** Returns the socket. *) method socket: t (** Returns the [Unix.file_desc] corresponding to the socket. *) method fd: Unix.file_descr (** Use [obj#close] to close the socket. Raises [Unix.Error] if there is an error. *) method close: unit (** Use [obj#dup] to duplicate the socket. Raises [Unix.Error] if there is an error. *) method dup: t (** Use [obj#dup2 sock] to duplicate the socket, overwriting the socket [sock] in the process. Raises [Unix.Error] if there is an error. *) method dup2: t -> unit (** Use [obj#getsockopt opt] to get the value of the socket option [opt]. Raises [Unix.Error] if there is an error. *) method getsockopt: 'a. ('a, P.AF.tag, P.ST.tag) Cf_socket.sockopt -> 'a (** Use [obj#setsockopt opt v] to set the value of the socket option [opt]. Raises [Unix.Error] if there is an error. *) method setsockopt: 'a. ('a, P.AF.tag, P.ST.tag) Cf_socket.sockopt -> 'a -> unit (** Use [self#getsockname] to get the locally bound endpoint address of the socket. Raises [Unix.Error] if there is an error. *) method private getsockname: address (** Use [self#getsockname] to get the remotely bound endpoint address of the socket. Raises [Unix.Error] if there is an error. *) method private getpeername: address (** Use [obj#shutdown cmd] to shutdown either sending or receiving (or both) on the socket. Raises [Unix.Error] if there is an error. *) method private shutdown: Unix.shutdown_command -> unit (** Use [self#bind sa] to bind the local endpoint address of the socket to the socket address [sa]. Raises [Unix.Error] if there is an error. *) method private bind: address -> unit end end (** The functor used to create the socket module. *) module Create(P: Cf_socket.P): T with module P = P (*--- End of File [ cf_sock_common.mli ] ---*) cf-0.10/cf_sock_dgram.ml0000644000175000017500000000721010433520573015033 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_sock_dgram.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) module type T = sig include Cf_sock_common.T with type P.ST.tag = [ `SOCK_DGRAM ] class endpoint: t -> object('self) inherit basic constraint 'self = #Cf_sock_common.endpoint method virtual getsockname: address method sendto: ?flags:Cf_socket.msg_flags -> string -> int -> int -> address -> int method recvfrom: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int * address method connect: address -> unit method virtual getpeername: address method send: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int method recv: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int method virtual shutdown: Unix.shutdown_command -> unit end end module Create(P: Cf_socket.P with module ST = Cf_socket.SOCK_DGRAM) = struct include Cf_sock_common.Create(P) module S0 = Cf_socket class endpoint sock = object inherit basic ~sock () method virtual getsockname: address method sendto ?(flags = S0.msg_flags_none) msg pos len addr = let addr = P.AF.to_sockaddr addr in S0.sendto socket_ msg pos len flags addr method recvfrom ?(flags = S0.msg_flags_none) msg pos len = let n, addr = S0.recvfrom socket_ msg pos len flags in n, P.AF.of_sockaddr addr method connect addr = let addr = P.AF.to_sockaddr addr in S0.connect socket_ addr method virtual getpeername: address method virtual shutdown: Unix.shutdown_command -> unit method send ?(flags = S0.msg_flags_none) msg pos len = S0.send socket_ msg pos len flags method recv ?(flags = S0.msg_flags_none) msg pos len = S0.recv socket_ msg pos len flags end end (*--- End of File [ cf_sock_dgram.ml ] ---*) cf-0.10/cf_sock_dgram.mli0000644000175000017500000001477310433520573015220 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_sock_dgram.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** Connection-oriented dgram transports with orderly release. This module extends the basic sockets interfaces defined in {!Cf_socket} and {!Cf_sock_common} with support for sockets of type [SOCK_DGRAM], i.e. connectionless transport (w/ optional multicast). UDP endpoints are sockets of this type. *) (** The type of the module containing the extensions to the {!Cf_sock_common.T} module type used for handling sockets of the [SOCK_DGRAM] socket type. *) module type T = sig include Cf_sock_common.T with type P.ST.tag = [ `SOCK_DGRAM ] (** Use [new endpoint sock] to construct an object derived from {!Cf_sock_common.T.basic} that sports methods for sending data to one or more endpoints using the socket [sock]. *) class endpoint: t -> object('self) inherit basic constraint 'self = #Cf_sock_common.endpoint (** Use [obj#getsockname] to obtain the actual local address associated with the socket. Raises [Unix.Error] if there is an error. *) method virtual getsockname: address (** Use [self#sendto ?flags buf pos len addr] to send [len] octets from the string [buf] starting at position [pos] to the remote address [addr], and optionally with the flags indicated by [flags]. Returns the number of octets actually sent. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) method sendto: ?flags:Cf_socket.msg_flags -> string -> int -> int -> address -> int (** Use [recvfrom sock buf pos len flags] to receive [len] octets into the string [buf] starting at position [pos] on the socket [sock] with the flags indicated by [flags]. Returns the number of octets actually received and the socket address of the remote endpoint that sent them. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) method recvfrom: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int * address (** Use [obj#connect] to associate the socket with the remote address [address]. Enables the use of the [getpeername], [send] and [recv] methods (may not be supported by all protocols). *) method connect: address -> unit (** Use [obj#getpeername] to obtain the actual remote address associated with the socket. Raises [Unix.Error] if there is an error. If there is no remote address associated with the socket, then a protocol-specific response is provided. Most protocols will return an address indicated the remote address is unspecified. *) method virtual getpeername: address (** Use [self#send ?flags buf pos len] to send [len] octets from the string [buf] starting at position [pos] to the remote address previously associated with the socket using the [connect] method, and optionally with the flags indicated by [flags]. Returns the number of octets actually sent. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) method send: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int (** Use [obj#recv ?flags buf pos len] to receive [len] octets to the string [buf] starting at position [pos] from the remote address previously associated with the socket using the [connect] method, and optionally with the flags indicated by [flags]. Returns the number of octets actually received. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) method recv: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int (** Use [obj#shutdown cmd] to shutdown either sending or receiving (or both) on the socket. Raises [Unix.Error] if there is an error. *) method virtual shutdown: Unix.shutdown_command -> unit end end (** The functor used to create the socket module. *) module Create(P: Cf_socket.P with module ST = Cf_socket.SOCK_DGRAM): T with module P = P (*--- End of File [ cf_sock_dgram.mli ] ---*) cf-0.10/cf_sock_dgram_p.c0000644000175000017500000000400010404616701015153 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_sock_dgram_p.c Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_sock_dgram_p.h" static value cf_sock_dgram_socktype = Val_unit; /*--- Lift the socket type ---*/ CAMLprim value cf_sock_dgram_socktype_lift(value unit) { CAMLparam0(); CAMLreturn(cf_sock_dgram_socktype); } /*--- Initialization primitive ---*/ CAMLprim value cf_sock_dgram_init(value unit) { register_global_root(&cf_sock_dgram_socktype); cf_sock_dgram_socktype = copy_nativeint(SOCK_DGRAM); return Val_unit; } /*--- End of File [ cf_sock_dgram_p.c ] ---*/ cf-0.10/cf_sock_dgram_p.h0000644000175000017500000000326410404616701015173 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_sock_dgram_p.h Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_SOCK_DGRAM_P_H #define _CF_SOCK_DGRAM_P_H #include "cf_socket_p.h" #endif /* defined(_CF_SOCK_DGRAM_P_H) */ /*--- End of File [ cf_sock_dgram_p.h ] ---*/ cf-0.10/cf_sock_stream.ml0000644000175000017500000001031210433520573015231 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_sock_stream.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) module type T = sig include Cf_sock_common.T with type P.ST.tag = [ `SOCK_STREAM ] class initiator: ?sock:t -> ?src:address -> address -> object inherit basic method virtual getsockname: address method connect: unit end class listener: ?sock:t -> address -> object inherit basic method virtual getsockname: address method listen: int -> unit method accept: t * address end class endpoint: t -> object('self) inherit basic constraint 'self = #Cf_sock_common.endpoint method virtual getsockname: address method virtual getpeername: address method send: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int method recv: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int method virtual shutdown: Unix.shutdown_command -> unit end end module Create(P: Cf_socket.P with module ST = Cf_socket.SOCK_STREAM) = struct include Cf_sock_common.Create(P) module S0 = Cf_socket class initiator ?sock ?src dst = let src = match src with | Some a -> P.AF.to_sockaddr a | None -> P.AF.unspecified in let dst = P.AF.to_sockaddr dst in object inherit basic ?sock () method virtual getsockname: address method connect = S0.connect socket_ dst initializer S0.bind socket_ src end class listener ?sock src = object inherit basic ?sock () as super method virtual getsockname: address method listen = S0.listen socket_ method accept = let socket, address = S0.accept socket_ in socket, (P.AF.of_sockaddr address) initializer S0.bind socket_ (P.AF.to_sockaddr src) end class endpoint sock = object inherit basic ~sock () method virtual getsockname: address method virtual getpeername: address method virtual shutdown: Unix.shutdown_command -> unit method send ?(flags = S0.msg_flags_none) msg pos len = S0.send socket_ msg pos len flags method recv ?(flags = S0.msg_flags_none) msg pos len = S0.recv socket_ msg pos len flags end end (*--- End of File [ cf_sock_stream.ml ] ---*) cf-0.10/cf_sock_stream.mli0000644000175000017500000001566710433520573015424 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_sock_stream.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** Connection-oriented stream transports with orderly release. This module extends the basic sockets interfaces defined in {!Cf_socket} and {!Cf_sock_common} with support for sockets of type [SOCK_STREAM], i.e. connection-oriented transports with orderly releases. TCP endpoints are sockets of this type. *) (** The type of the module containing the extensions to the {!Cf_sock_common.T} module type used for handling sockets of the [SOCK_STREAM] socket type. *) module type T = sig include Cf_sock_common.T with type P.ST.tag = [ `SOCK_STREAM ] (** Use [new initiator ?sock ?src addr] to construct an object derived from {!Cf_sock_common.T.basic} that sports a method for connecting to a remote peer endpoint at the address [addr]. If the [?sock] argument is provided then the socket is treated as an unbound socket and used for the connection. Otherwise, a new socket is created. If the [?src] argument is provided, then the socket is bound to the specific address. Otherwise, the socket is bound to the unspecified address for the protocol/address family. Raises [Unix.Error] if an error occurs. *) class initiator: ?sock:t -> ?src:address -> address -> object inherit basic (** Use [obj#getsockname] to obtain the actual local address associated with the socket. Raises [Unix.Error] if there is an error. *) method virtual getsockname: address (** Use [obj#connect] to initiate the connection to the remote address provided to the constructor. *) method connect: unit end (** Use [new listener ?sock addr] to construct an object derived from {!Cf_sock_common.T.basic} that sports methods for passive listening for incoming connections at the local address [addr]. If the [?sock] argument is provided, then the socket is treated as a newly created socket and used for the listener. Otherwise, a new socket is created. Raises [Unix.Error] if an error occurs. *) class listener: ?sock:t -> address -> object inherit basic (** Use [obj#getsockname] to obtain the actual local address associated with the socket. Raises [Unix.Error] if there is an error. *) method virtual getsockname: address (** Use [obj#listen n] to place the socket into listening mode with a backlog queue depth of [n] pending connections. Raises [Unix.Error] if there is an error. *) method listen: int -> unit (** Use [obj#accept] to accept a new connection from a remote peer. Returns a new socket and the address of its remote endpoint. Raises [Unix.Error] if an error occurs. *) method accept: t * address end (** Use [new endpoint sock] to construct an object derived from {!Cf_sock_common.T.basic} that sports methods for sending data to and receiving data from an already connected socket [sock]. *) class endpoint: t -> object('self) inherit basic constraint 'self = #Cf_sock_common.endpoint (** Use [obj#getsockname] to obtain the actual local address associated with the socket. Raises [Unix.Error] if there is an error. *) method virtual getsockname: address (** Use [obj#getpeername] to obtain the actual remote address associated with the socket. Raises [Unix.Error] if there is an error. *) method virtual getpeername: address (** Use [self#send ?flags buf pos len] to send [len] octets from the string [buf] starting at position [pos], optionally with the flags indicated by [flags]. Returns the number of octets actually sent. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) method send: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int (** Use [obj#recv ?flags buf pos len] to receive [len] octets to the string [buf] starting at position [pos], optionally with the flags indicated by [flags]. Returns the number of octets actually received. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) method recv: ?flags:Cf_socket.msg_flags -> string -> int -> int -> int (** Use [obj#shutdown cmd] to shutdown either sending or receiving (or both) on the socket. Raises [Unix.Error] if there is an error. *) method virtual shutdown: Unix.shutdown_command -> unit end end (** The functor used to create the socket module. *) module Create(P: Cf_socket.P with module ST = Cf_socket.SOCK_STREAM): T with module P = P (*--- End of File [ cf_sock_stream.mli ] ---*) cf-0.10/cf_sock_stream_p.c0000644000175000017500000000401210404616701015357 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_sock_stream_p.c Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_sock_stream_p.h" static value cf_sock_stream_socktype = Val_unit; /*--- Lift the socket type ---*/ CAMLprim value cf_sock_stream_socktype_lift(value unit) { CAMLparam0(); CAMLreturn(cf_sock_stream_socktype); } /*--- Initialization primitive ---*/ CAMLprim value cf_sock_stream_init(value unit) { register_global_root(&cf_sock_stream_socktype); cf_sock_stream_socktype = copy_nativeint(SOCK_STREAM); return Val_unit; } /*--- End of File [ cf_sock_stream_p.c ] ---*/ cf-0.10/cf_sock_stream_p.h0000644000175000017500000000327110404616701015372 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_sock_stream_p.h Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_SOCK_STREAM_P_H #define _CF_SOCK_STREAM_P_H #include "cf_socket_p.h" #endif /* defined(_CF_SOCK_STREAM_P_H) */ /*--- End of File [ cf_sock_stream_p.h ] ---*/ cf-0.10/cf_socket.ml0000644000175000017500000001471710433520573014224 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_socket.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) external init_: unit -> unit = "cf_socket_init";; init_ ();; type 'st socktype type 'af domain type protocol type 'af sockaddr type ('af,'st) t external create: 'af domain -> 'st socktype -> protocol -> ('af,'st) t = "cf_socket_create" external createpair: 'af domain -> 'st socktype -> protocol -> (('af,'st) t as 'fd) * 'fd = "cf_socket_createpair" external to_unix_file_descr: ('af,'st) t -> Unix.file_descr = "cf_socket_to_unix_file_descr" external domain_of_sockaddr: 'af sockaddr -> 'af domain = "cf_socket_domain_of_sockaddr" external dup: (('af,'st) t as 'fd) -> 'fd = "cf_socket_dup" external dup2: (('af,'st) t as 'fd) -> 'fd -> unit = "cf_socket_dup2" external getsockname: ('af, 'st) t -> 'af sockaddr = "cf_socket_getsockname" external getpeername: ('af, 'st) t -> 'af sockaddr = "cf_socket_getpeername" external bind: ('af,'st) t -> 'af sockaddr -> unit = "cf_socket_bind" external connect: ('af,'st) t -> 'af sockaddr -> unit = "cf_socket_connect" external listen: ('af, ([< `SOCK_STREAM | `SOCK_SEQPACKET ] as 'st)) t -> int -> unit = "cf_socket_listen" external accept: ('af, ([ `SOCK_STREAM ] as 'st)) t -> ('af, 'st) t * 'af sockaddr = "cf_socket_accept" let shutdown sock cmd = Unix.shutdown (to_unix_file_descr sock) cmd let close sock = Unix.close (to_unix_file_descr sock) type msg_flags = { msg_oob: bool; msg_peek: bool; msg_dontroute: bool; msg_eor: bool; msg_trunc: bool; msg_ctrunc: bool; msg_waitall: bool; msg_dontwait: bool; (* __APPLE__ msg_eof: bool; msg_flush: bool; msg_hold: bool; msg_send: bool; msg_havemore: bool; msg_rcvmore: bool; *) } let msg_flags_none = { msg_oob = false; msg_peek = false; msg_dontroute = false; msg_eor = false; msg_trunc = false; msg_ctrunc = false; msg_waitall = false; msg_dontwait = false; (* __APPLE__ msg_eof = false; msg_flush = false; msg_hold = false; msg_send = false; msg_havemore = false; msg_rcvmore = false; *) } external send: ('af, 'st) t -> string -> int -> int -> msg_flags -> int = "cf_socket_send" external sendto: ('af, ([ `SOCK_DGRAM ] as 'st)) t -> string -> int -> int -> msg_flags -> 'af sockaddr -> int = "cf_socket_sendto_bytecode" "cf_socket_sendto_native" external recv: ('af, 'st) t -> string -> int -> int -> msg_flags -> int = "cf_socket_recv" external recvfrom: ('af, ([ `SOCK_DGRAM ] as 'st)) t -> string -> int -> int -> msg_flags -> int * 'af sockaddr = "cf_socket_recvfrom" module type AF = sig type tag type address val domain: tag domain val to_sockaddr: address -> tag sockaddr val of_sockaddr: tag sockaddr -> address val unspecified: tag sockaddr end module type ST = sig type tag val socktype: tag socktype end module type P = sig module AF: AF module ST: ST val protocol: protocol end external sock_stream_init_: unit -> unit = "cf_sock_stream_init";; sock_stream_init_ ();; external sock_stream_socktype_lift_: unit -> 'a socktype = "cf_sock_stream_socktype_lift" module SOCK_STREAM = struct type tag = [ `SOCK_STREAM ] let socktype = sock_stream_socktype_lift_ () end external sock_dgram_init_: unit -> unit = "cf_sock_dgram_init";; sock_dgram_init_ ();; external sock_dgram_socktype_lift_: unit -> 'a socktype = "cf_sock_dgram_socktype_lift" module SOCK_DGRAM = struct type tag = [ `SOCK_DGRAM ] let socktype = sock_dgram_socktype_lift_ () end type ('v,-'af,-'st) sockopt external getsockopt: ('af,'st) t -> ('v,'af,'st) sockopt -> 'v = "cf_socket_getsockopt" external setsockopt: ('af,'st) t -> ('v,'af,'st) sockopt -> 'v -> unit = "cf_socket_setsockopt" type sockopt_index = SO_DEBUG | SO_REUSEADDR | SO_REUSEPORT | SO_KEEPALIVE | SO_DONTROUTE | SO_LINGER | SO_BROADCAST | SO_OOBINLINE | SO_SNDBUF | SO_RCVBUF | SO_SNDLOWAT | SO_RCVLOWAT | SO_SNDTIMEO | SO_RCVTIMEO | SO_ERROR | SO_NOSIGPIPE external sockopt_lift: sockopt_index -> ('a, 'b, 'c) sockopt = "cf_socket_sockopt_lift" let so_debug = Obj.magic (sockopt_lift SO_DEBUG) let so_reuseaddr = Obj.magic (sockopt_lift SO_REUSEADDR) let so_reuseport = Obj.magic (sockopt_lift SO_REUSEPORT) let so_keepalive = Obj.magic (sockopt_lift SO_KEEPALIVE) let so_dontroute = Obj.magic (sockopt_lift SO_DONTROUTE) let so_linger = Obj.magic (sockopt_lift SO_LINGER) let so_broadcast = Obj.magic (sockopt_lift SO_BROADCAST) let so_oobinline = Obj.magic (sockopt_lift SO_OOBINLINE) let so_sndbuf = Obj.magic (sockopt_lift SO_SNDBUF) let so_rcvbuf = Obj.magic (sockopt_lift SO_RCVBUF) let so_sndlowat = Obj.magic (sockopt_lift SO_SNDLOWAT) let so_rcvlowat = Obj.magic (sockopt_lift SO_RCVLOWAT) let so_sndtimeo = Obj.magic (sockopt_lift SO_SNDTIMEO) let so_rcvtimeo = Obj.magic (sockopt_lift SO_RCVTIMEO) let so_error = Obj.magic (sockopt_lift SO_ERROR) let so_nosigpipe = Obj.magic (sockopt_lift SO_NOSIGPIPE) (*--- End of File [ cf_socket.ml ] ---*) cf-0.10/cf_socket.mli0000644000175000017500000003205510433520573014370 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_socket.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** Extended network sockets interface. *) (** {6 Overview} The Objective Caml [Unix] library contains a simplified interface for manipulating network sockets that is sufficient for most applications. This module and its cognates implement an alternative interface for using network sockets that offers the same extensibility as the Berkeley sockets interface does in the C language, while using the Objective Caml type system to enforce usage constraints. *) (** {6 Types} *) (** The abstract type of socket type identifiers. The type parameter is a shadow type attributed to the socket type identifier value. *) type 'st socktype (** The abstract type of socket domain identifiers. The type parameter is a shadow type attributed to the protocol/address family identifier value. *) type 'af domain (** The abstract type of socket protocol identifiers. *) type protocol (** The abstract type of socket address structures. Internally, these are represented as custom Objective Caml blocks of precisely the size of the underlying [struct sockaddr_xxx] structure. The type parameter is a shadow type attributed to the address family identifier value. *) type 'af sockaddr (** The abstract type of socket option identifiers. The first type parameter is the type of values the socket option sets and gets. The second type parameter is the shadow type used to constrain the use of the option to sockets of the appropriate protocol family. The third type parameter is the shadow type used to constrain the use of the option to sockets of the appropriate socket type. *) type ('v,-'af,-'st) sockopt (** The abstract type of socket descriptors. The type parameters are the shadow types associated with the protocol/address family and the socket type of the socket, respectively. *) type ('af,'st) t (** The record used to select the flags used with the [send] and [recv] functions (and their cognates). *) type msg_flags = { msg_oob: bool; (** Message is out-of-band/expedited. *) msg_peek: bool; (** Read message without dequeue. *) msg_dontroute: bool; (** Use direct interface. *) msg_eor: bool; (** End of record. *) msg_trunc: bool; (** Message truncated in receive. *) msg_ctrunc: bool; (** Control message truncated in receive. *) msg_waitall: bool; (** Block until message completely received. *) msg_dontwait: bool; (** Don't block. *) (**/**) (* __APPLE__ msg_eof: bool; msg_flush: bool; msg_hold: bool; msg_send: bool; msg_havemore: bool; msg_rcvmore: bool; *) } (** {6 Modules and Module Types} *) (** The module type used to define a socket address/protocol family. *) module type AF = sig (** The shadow type *) type tag (** The concrete type of the socket address for the address family. *) type address (** The value of the socket domain identifier. *) val domain: tag domain (** Use [to_sockaddr a] to create an abstract socket address value corresponding to the address [a]. *) val to_sockaddr: address -> tag sockaddr (** Use [of_sockaddr sa] to create an address corresponding to the abstract socket address value [sa]. *) val of_sockaddr: tag sockaddr -> address (** The unspecified socket address, used for binding to arbitrary local endpoint addresses. *) val unspecified: tag sockaddr end (** The module type used to define a socket type. *) module type ST = sig (** The shadow type. *) type tag (** The value of the socket type identifier. *) val socktype: tag socktype end (** The module type used to define a socket protocol. *) module type P = sig (** The socket address/protocol family module. *) module AF: AF (** The socket type module. *) module ST: ST (** The abstract protocol identifier. *) val protocol: protocol end (** The module defining the [SOCK_STREAM] socket type. *) module SOCK_STREAM: ST with type tag = [ `SOCK_STREAM ] module SOCK_DGRAM: ST with type tag = [ `SOCK_DGRAM ] (** {6 Constants} *) (** The default value of the message flags structure, i.e. no flags set. *) val msg_flags_none: msg_flags (** {6 Functions} Most of the functions here are fairly straightforward wrappers around the Berkeley sockets API. For a more convenient interface, consider using the object-oriented alternative, described in the next section. *) (** Use [create dom st p] to create a new socket descriptor with the socket domain [dom], the socket type [st] and the protocol identifier [p]. Raises [Unix.Error] if a system error occurs. *) val create: 'af domain -> 'st socktype -> protocol -> ('af,'st) t (** Use [createpair dom st p] to create a pair of new socket descriptors that are already bound and connected to one another, using the socket domain [dom], the socket type [st] and the protocol identifier [p]. Raises [Unix.Error] if a system error occurs. *) val createpair: 'af domain -> 'st socktype -> protocol -> (('af,'st) t as 'fd) * 'fd (** Use [to_unix_file_descr sock] to obtain the file descriptor to use with functions in the [Unix] library that corresponds to the socket descriptor [sock]. *) val to_unix_file_descr: ('af,'st) t -> Unix.file_descr (** Use [domain_of_sockaddr sa] to obtain the socket domain identifier associated with a socket address of unknown address family. *) val domain_of_sockaddr: 'af sockaddr -> 'af domain (** Use [dup sock] to create a duplicate of socket descriptor [sock]. Raises [Unix.Error] if there is an error. *) val dup: (('af,'st) t as 'fd) -> 'fd (** Use [dup2 sock sock2] to create a duplicate of socket descriptor [sock] by overwriting the descriptor [sock2]. Raises [Unix.Error] if there is an error. *) val dup2: (('af,'st) t as 'fd) -> 'fd -> unit (** Use [getsockname sock] to create a new socket address corresponding to the local bound endpoint of the socket [sock]. Raises [Unix.Error] if there is an error. *) val getsockname: ('af, 'st) t -> 'af sockaddr (** Use [getpeername sock] to create a new socket address corresponding to the connected remote endpoint of the socket [sock]. Raises [Unix.Error] if there is an error. *) val getpeername: ('af, 'st) t -> 'af sockaddr (** Use [bind sock sa] to bind the local endpoint address of the socket [sock] to the socket address [sa]. Raises [Unix.Error] if there is an error. *) val bind: ('af,'st) t -> 'af sockaddr -> unit (** Use [connect sock sa] to connect the remote endpoint address of the socket [sock] to the socket address [sa]. Raises [Unix.Error] if there is an error. *) val connect: ('af,'st) t -> 'af sockaddr -> unit (** Use [listen sock n] to set the socket [sock] into the mode of listening for connections with a backlog queue [n] spaces deep. Raises [Unix.Error] if there is an error. *) val listen: ('af,([< `SOCK_STREAM | `SOCK_SEQPACKET ] as 'st)) t -> int -> unit (** Use [accept sock] to accept a connected request on the listening socket [sock]. Returns a new socket descriptor and the socket address of the remote peer. Raises [Unix.Error] if there is an error. *) val accept: ('af,([ `SOCK_STREAM ] as 'st)) t -> ('af,'st) t * 'af sockaddr (** Use [shutdown sock cmd] to shutdown either sending or receiving (or both) on the socket [sock]. Raises [Unix.Error] if there is an error. *) val shutdown: ('af,'st) t -> Unix.shutdown_command -> unit (** Use [close sock] to close a socket descriptor. Raises [Unix.Error] if there is an error. *) val close: ('af,'st) t -> unit (** Use [send sock buf pos len flags] to send [len] octets from the string [buf] starting at position [pos] on the socket [sock] with the flags indicated by [flags]. Returns the number of octets actually sent. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) val send: ('af, 'st) t -> string -> int -> int -> msg_flags -> int (** Use [sendto sock buf pos len flags sa] to send [len] octets from the string [buf] starting at position [pos] on the socket [sock] with the flags indicated by [flags] to the socket address [sa]. Returns the number of octets actually sent. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) val sendto: ('af, ([ `SOCK_DGRAM ] as 'st)) t -> string -> int -> int -> msg_flags -> 'af sockaddr -> int (** Use [recv sock buf pos len flags] to receive [len] octets into the string [buf] starting at position [pos] on the socket [sock] with the flags indicated by [flags]. Returns the number of octets actually received. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) val recv: ('af, 'st) t -> string -> int -> int -> msg_flags -> int (** Use [recvfrom sock buf pos len flags] to receive [len] octets into the string [buf] starting at position [pos] on the socket [sock] with the flags indicated by [flags]. Returns the number of octets actually received and the socket address of the remote endpoint that sent them. Raises [Unix.Error] if there is an error. Raises [Invalid_argument] if [pos] and [len] do not correspond to a valid substring of [buf]. *) val recvfrom: ('af, ([ `SOCK_DGRAM ] as 'st)) t -> string -> int -> int -> msg_flags -> int * 'af sockaddr (** Use [getsockopt sock opt] to obtain the value associated with the socket option [opt] for the socket descriptor [sock]. Raises [Unix.Error] if there is an error. *) val getsockopt: ('af,'st) t -> ('v,'af,'st) sockopt -> 'v (** Use [setsockopt sock opt v] to set the value associated with the socket option [opt] for the socket descriptor [sock] to the value [v]. Raises [Unix.Error] if there is an error. *) val setsockopt: ('af,'st) t -> ('v,'af,'st) sockopt -> 'v -> unit (** {6 Socket Options} The following socket options are available on sockets of all socket types and address/protocol families. *) (** Enables recording of debugging information. *) val so_debug: (bool,'af,'st) sockopt (** Enables local address reuse. *) val so_reuseaddr: (bool,'af,'st) sockopt (** Enables duplicate address and port bindings. *) val so_reuseport: (bool,'af,'st) sockopt (** Enables connection keep-alives. *) val so_keepalive: (bool,'af,'st) sockopt (** Enables routing bypass for outgoing messages. *) val so_dontroute: (bool,'af,'st) sockopt (** Enables linger on close if data present. *) val so_linger: (int option,'af,'st) sockopt (** Enables permission to transmit broadcast messages. *) val so_broadcast: (bool,'af,'st) sockopt (** Enables in-band reception of out-of-band/expedited messages. *) val so_oobinline: (bool,'af,'st) sockopt (** Set buffer size for output. *) val so_sndbuf: (int,'af,'st) sockopt (** Set buffer size for input. *) val so_rcvbuf: (int,'af,'st) sockopt (** Set minimum octet count for output. *) val so_sndlowat: (int,'af,'st) sockopt (** Set minimum octet count for input. *) val so_rcvlowat: (int,'af,'st) sockopt (** Set timeout for output. *) val so_sndtimeo: (float,'af,'st) sockopt (** Set timeout for input. *) val so_rcvtimeo: (float,'af,'st) sockopt (** Get and clear the error on the socket (get only). *) val so_error: (unit,'af,'st) sockopt (** Do not generate SIGPIPE. Instead raise [Unix.Error Unix.EPIPE]. *) val so_nosigpipe: (bool,'af,'st) sockopt (*--- End of File [ cf_socket.mli ] ---*) cf-0.10/cf_socket_p.c0000644000175000017500000006357410404616701014357 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_socket_p.c Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_socket_p.h" #include #include #include #include #include #define FAILWITH(S) (failwith("Cf_socket." S)) #define INVALID_ARGUMENT(S) (invalid_argument("Cf_socket." S)) static int cf_socket_domain_compare(value v1, value v2) { CAMLparam2(v1, v2); int pf1, pf2; pf1 = Cf_socket_domain_val(v1)->d_domain; pf2 = Cf_socket_domain_val(v2)->d_domain; if (pf1 == pf2) { pf1 = Cf_socket_domain_val(v1)->d_family; pf2 = Cf_socket_domain_val(v2)->d_family; } CAMLreturn(pf2 - pf1); } static long cf_socket_domain_hash(value v) { CAMLparam1(v); CAMLreturn((long) Cf_socket_domain_val(v)->d_domain); } static struct custom_operations cf_socket_domain_op = { "org.conjury.ocnae.cf.socket_domain", custom_finalize_default, cf_socket_domain_compare, cf_socket_domain_hash, custom_serialize_default, custom_deserialize_default }; static int cf_socket_compare(value v1, value v2) { CAMLparam2(v1, v2); CAMLreturn(Cf_socket_val(v2)->s_fd - Cf_socket_val(v1)->s_fd); } static long cf_socket_hash(value v) { CAMLparam1(v); CAMLreturn((long) Cf_socket_val(v)->s_fd); } static struct custom_operations cf_socket_op = { "org.conjury.ocnae.cf.socket", custom_finalize_default, cf_socket_compare, cf_socket_hash, custom_serialize_default, custom_deserialize_default }; value cf_socket_domain_alloc(const Cf_socket_domain_t* ptr) { value sVal; sVal = alloc_custom(&cf_socket_domain_op, sizeof *ptr, 0, 1); memcpy(Cf_socket_domain_val(sVal), ptr, sizeof *ptr); return sVal; } value cf_socket_alloc (int fd, int socktype, int protocol, const Cf_socket_domain_t* domainPtr) { value sVal; Cf_socket_t* sPtr; sVal = alloc_custom(&cf_socket_op, sizeof *sPtr, 0, 1); sPtr = Cf_socket_val(sVal); sPtr->s_fd = fd; sPtr->s_socktype = socktype; sPtr->s_protocol = protocol; sPtr->s_domain = *domainPtr; return sVal; } /*--- external create: 'af domain_t -> 'st socktype_t -> protocol_t -> ('st,'af) t = "cf_socket_create" ---*/ CAMLprim value cf_socket_create (value domainVal, value typeVal, value protocolVal) { CAMLparam3(domainVal, typeVal, protocolVal); int type, protocol, fd; const Cf_socket_domain_t* domainPtr; domainPtr = Cf_socket_domain_val(domainVal); type = Nativeint_val(typeVal); protocol = Nativeint_val(protocolVal); fd = socket(domainPtr->d_domain, type, protocol); if (fd < 0) uerror("socket", Nothing); CAMLreturn(cf_socket_alloc(fd, type, protocol, domainPtr)); } /*--- external createpair: 'af domain_t -> 'st socktype_t -> protocol_t -> (('st,'af) t as 'fd) * 'fd = "cf_socket_createpair" ---*/ CAMLprim value cf_socket_createpair (value domainVal, value typeVal, value protocolVal) { CAMLparam3(domainVal, typeVal, protocolVal); CAMLlocal1(resultVal); CAMLlocalN(fdVal, 2); int type, protocol, fd[2]; const Cf_socket_domain_t* domainPtr; domainPtr = Cf_socket_domain_val(domainVal); type = Nativeint_val(typeVal); protocol = Nativeint_val(protocolVal); if (socketpair(domainPtr->d_domain, type, protocol, fd)) uerror("socketpair", Nothing); fdVal[0] = cf_socket_alloc(fd[0], type, protocol, domainPtr); fdVal[1] = cf_socket_alloc(fd[1], type, protocol, domainPtr); resultVal = alloc_small(2, 0); Store_field(resultVal, 0, fdVal[0]); Store_field(resultVal, 1, fdVal[1]); CAMLreturn(resultVal); } /*--- external to_unix_file_descr: ('af,'st) t -> Unix.file_descr = "cf_socket_to_unix_file_descr" ---*/ CAMLprim value cf_socket_to_unix_file_descr(value sockVal) { CAMLparam1(sockVal); CAMLreturn(Val_int(Cf_socket_val(sockVal)->s_fd)); } /*--- external domain_of_sockaddr: 'af sockaddr_t -> 'af domain_t = "cf_socket_domain_of_unit_sockaddr" ---*/ CAMLprim value cf_socket_domain_of_sockaddr(value sxVal) { CAMLparam1(sxVal); const Cf_socket_sockaddrx_unit_t* sxPtr; sxPtr = Cf_socket_sockaddrx_unit_val(sxVal); CAMLreturn(copy_nativeint(sxPtr->sx_sockaddr.sa_family)); } /*--- external dup: (('af,'st) t as 'fd) -> 'fd = "cf_socket_dup" ---*/ CAMLprim value cf_socket_dup(value sockVal) { CAMLparam1(sockVal); CAMLlocal1(resultVal); const Cf_socket_t* sockPtr = Cf_socket_val(sockVal); int fd; fd = dup(sockPtr->s_fd); if (fd == -1) uerror("dup", Nothing); resultVal = cf_socket_alloc (fd, sockPtr->s_socktype, sockPtr->s_protocol, &sockPtr->s_domain); CAMLreturn(resultVal); } /*--- external dup2: (('af,'st) t as 'fd) -> 'fd -> unit = "cf_socket_dup2" ---*/ CAMLprim void cf_socket_dup2(value sock1Val, value sock2Val) { CAMLparam2(sock1Val, sock2Val); const Cf_socket_t* sock1Ptr = Cf_socket_val(sock1Val); const Cf_socket_t* sock2Ptr = Cf_socket_val(sock2Val); if (dup2(sock1Ptr->s_fd, sock2Ptr->s_fd) == -1) uerror("dup", Nothing); CAMLreturn0; } static const int cf_socket_msg_flags_array[] = { MSG_OOB, MSG_PEEK, MSG_DONTROUTE, MSG_OOB, MSG_EOR, MSG_TRUNC, MSG_CTRUNC, MSG_WAITALL, MSG_DONTWAIT }; #define Cf_socket_msg_flags_array_size \ (sizeof cf_socket_msg_flags_array / sizeof cf_socket_msg_flags_array[0]) int cf_socket_msg_flags_to_int(value flagsVal) { int flags = 0; int i; for (i = 0; i < Cf_socket_msg_flags_array_size; ++i) if (Field(flagsVal, i) != Val_false) flags |= cf_socket_msg_flags_array[i]; return flags; } value cf_socket_msg_flags_of_int(int flags) { CAMLparam0(); CAMLlocal1(flagsVal); int i; flagsVal = alloc_small(Cf_socket_msg_flags_array_size, 0); for (i = 0; i < Cf_socket_msg_flags_array_size; ++i) Store_field(flagsVal, i, (flags & cf_socket_msg_flags_array[i]) ? Val_true : Val_false); CAMLreturn(flagsVal); } /*--- external getsockname: ('af,'st) t -> 'af sockaddr_t = "cf_socket_getsockname" ---*/ CAMLprim value cf_socket_getsockname(value sockVal) { CAMLparam1(sockVal); CAMLlocal1(sxVal); const Cf_socket_t* sockPtr; struct sockaddr_storage ss; struct sockaddr* saPtr; socklen_t addrLen; int v; sockPtr = Cf_socket_val(sockVal); saPtr = (struct sockaddr*) &ss; addrLen = sizeof ss; v = getsockname(sockPtr->s_fd, saPtr, &addrLen); if (v == -1) uerror("getsockname", Nothing); sxVal = sockPtr->s_domain.d_consaddr(saPtr, addrLen); CAMLreturn(sxVal); } /*--- external getpeername: ('af,'st) t -> 'af sockaddr_t = "cf_socket_getpeername" ---*/ CAMLprim value cf_socket_getpeername(value sockVal) { CAMLparam1(sockVal); CAMLlocal1(sxVal); const Cf_socket_t* sockPtr; struct sockaddr_storage ss; struct sockaddr* saPtr; socklen_t addrLen; int v; sockPtr = Cf_socket_val(sockVal); saPtr = (struct sockaddr*) &ss; addrLen = sizeof ss; v = getpeername(sockPtr->s_fd, saPtr, &addrLen); if (v == -1) uerror("getpeername", Nothing); sxVal = sockPtr->s_domain.d_consaddr(saPtr, addrLen); CAMLreturn(sxVal); } /*--- external bind: ('af,'st) t -> 'af sockaddr_t -> unit = "cf_socket_bind" ---*/ CAMLprim void cf_socket_bind(value sockVal, value sxVal) { CAMLparam2(sockVal, sxVal); const Cf_socket_t* sockPtr; const Cf_socket_sockaddrx_unit_t* sxPtr; sockPtr = Cf_socket_val(sockVal); sxPtr = Cf_socket_sockaddrx_unit_val(sxVal); if (bind(sockPtr->s_fd, &sxPtr->sx_sockaddr, sxPtr->sx_socklen)) uerror("bind", Nothing); CAMLreturn0; } /*--- external connect: ('af,'st) t -> 'af sockaddr_t -> unit = "cf_socket_connect" ---*/ CAMLprim void cf_socket_connect(value sockVal, value sxVal) { CAMLparam2(sockVal, sxVal); const Cf_socket_t* sockPtr; const Cf_socket_sockaddrx_unit_t* sxPtr; int result, error; sockPtr = Cf_socket_val(sockVal); sxPtr = Cf_socket_sockaddrx_unit_val(sxVal); enter_blocking_section(); result = connect(sockPtr->s_fd, &sxPtr->sx_sockaddr, sxPtr->sx_socklen); error = errno; #ifdef __APPLE__ /* Mac OS X does not return the error in errno on non-blocking sockets */ if (result && error == EINVAL) { socklen_t optlen = sizeof error; getsockopt(sockPtr->s_fd, SOL_SOCKET, SO_ERROR, &error, &optlen); } #endif leave_blocking_section(); if (result) unix_error(error, "connect", Nothing); CAMLreturn0; } /*--- external listen: ('af, ([< `SOCK_STREAM ] as 'st)) t -> int -> unit = "cf_socket_listen" ---*/ CAMLprim void cf_socket_listen(value sockVal, value backlogVal) { CAMLparam2(sockVal, backlogVal); const Cf_socket_t* sockPtr; int backlog; sockPtr = Cf_socket_val(sockVal); backlog = Int_val(backlogVal); if (listen(sockPtr->s_fd, backlog)) uerror("listen", Nothing); CAMLreturn0; } /*--- external accept: ('af, ([< `SOCK_STREAM ] as 'st)) t -> ('af, 'st) t * 'af sockaddr_t = "cf_socket_accept" ---*/ CAMLprim value cf_socket_accept(value sockVal) { CAMLparam1(sockVal); CAMLlocal3(newSockVal, sxVal, resultVal); const Cf_socket_t* sockPtr; struct sockaddr_storage ss; struct sockaddr* saPtr; socklen_t addrLen; int newFd, error; sockPtr = Cf_socket_val(sockVal); saPtr = (struct sockaddr*) &ss; addrLen = sizeof ss; enter_blocking_section(); newFd = accept(sockPtr->s_fd, saPtr, &addrLen); error = errno; leave_blocking_section(); if (newFd == -1) unix_error(error, "accept", Nothing); sxVal = sockPtr->s_domain.d_consaddr(saPtr, addrLen); newSockVal = cf_socket_alloc (newFd, sockPtr->s_socktype, sockPtr->s_protocol, &sockPtr->s_domain); resultVal = alloc_small(2, 0); Store_field(resultVal, 0, newSockVal); Store_field(resultVal, 1, sxVal); CAMLreturn(resultVal); } /*--- external send: ('af, 'st) t -> string -> int -> int -> msg_flags_t -> int = "cf_socket_send" ---*/ CAMLprim value cf_socket_send (value sockVal, value dataVal, value posVal, value lenVal, value flagsVal) { CAMLparam5(sockVal, dataVal, posVal, lenVal, flagsVal); const Cf_socket_t* sockPtr; const char* dataPtr; int fd, pos, len, flags, result, error; sockPtr = Cf_socket_val(sockVal); dataPtr = String_val(dataVal); pos = Int_val(posVal); len = Int_val(lenVal); flags = cf_socket_msg_flags_to_int(flagsVal); enter_blocking_section(); result = send(sockPtr->s_fd, dataPtr + pos, len, flags); error = errno; leave_blocking_section(); if (result < 0) unix_error(error, "send", Nothing); CAMLreturn(Val_int(result)); } /*--- external sendto: ('af, ([< `SOCK_DGRAM ] as 'st)) t -> string -> int -> int -> msg_flags_t -> int = "cf_socket_sendto_bytecode" "cf_socket_sendto_native" ---*/ CAMLprim value cf_socket_sendto_native (value sockVal, value dataVal, value posVal, value lenVal, value flagsVal, value sxVal) { CAMLparam5(sockVal, dataVal, posVal, lenVal, flagsVal); CAMLxparam1(sxVal); const Cf_socket_t* sockPtr; const char* dataPtr; int fd, pos, len, flags, result, error; const Cf_socket_sockaddrx_unit_t* sxPtr; sockPtr = Cf_socket_val(sockVal); dataPtr = String_val(dataVal); pos = Int_val(posVal); len = Int_val(lenVal); flags = cf_socket_msg_flags_to_int(flagsVal); sxPtr = Cf_socket_sockaddrx_unit_val(sxVal); enter_blocking_section(); result = sendto(sockPtr->s_fd, dataPtr + pos, len, flags, &sxPtr->sx_sockaddr, sxPtr->sx_socklen); error = errno; leave_blocking_section(); if (result < 0) unix_error(error, "sendto", Nothing); CAMLreturn(Val_int(result)); } CAMLprim value cf_socket_sendto_bytecode(value * argv, int argn) { return cf_socket_sendto_native (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]); } /*--- external recv: ('af, 'st) t -> string -> int -> int -> msg_flags_t -> int = "cf_socket_recv" ---*/ CAMLprim value cf_socket_recv (value sockVal, value dataVal, value posVal, value lenVal, value flagsVal) { CAMLparam5(sockVal, dataVal, posVal, lenVal, flagsVal); const Cf_socket_t* sockPtr; char* dataPtr; int fd, pos, len, flags, result, error; sockPtr = Cf_socket_val(sockVal); dataPtr = String_val(dataVal); pos = Int_val(posVal); len = Int_val(lenVal); flags = cf_socket_msg_flags_to_int(flagsVal); enter_blocking_section(); result = recv(sockPtr->s_fd, dataPtr + pos, len, flags); error = errno; leave_blocking_section(); if (result < 0) unix_error(error, "recv", Nothing); CAMLreturn(Val_int(result)); } /*--- external recvfrom: ('af, ([< `SOCK_DGRAM ] as 'st)) t -> string -> int -> int -> msg_flags_t -> int = "cf_socket_recvfrom" ---*/ CAMLprim value cf_socket_recvfrom (value sockVal, value dataVal, value posVal, value lenVal, value flagsVal) { CAMLparam5(sockVal, dataVal, posVal, lenVal, flagsVal); CAMLlocal2(sxVal, resultVal); const Cf_socket_t* sockPtr; char* dataPtr; int fd, pos, len, flags, result, error; struct sockaddr_storage ss; struct sockaddr* saPtr; socklen_t addrLen; sockPtr = Cf_socket_val(sockVal); dataPtr = String_val(dataVal); pos = Int_val(posVal); len = Int_val(lenVal); flags = cf_socket_msg_flags_to_int(flagsVal); saPtr = (struct sockaddr*) &ss; addrLen = sizeof ss; enter_blocking_section(); result = recvfrom(sockPtr->s_fd, dataPtr + pos, len, flags, saPtr, &addrLen); error = errno; leave_blocking_section(); if (result < 0) unix_error(error, "recvfrom", Nothing); sxVal = sockPtr->s_domain.d_consaddr(saPtr, addrLen); resultVal = alloc_small(2, 0); Store_field(resultVal, 0, Val_int(result)); Store_field(resultVal, 1, sxVal); CAMLreturn(resultVal); } static int cf_socket_option_compare(value v1, value v2) { CAMLparam2(v1, v2); const Cf_socket_option_t** opt1PtrPtr; const Cf_socket_option_t** opt2PtrPtr; int n; opt1PtrPtr = Cf_socket_option_val(v1); opt2PtrPtr = Cf_socket_option_val(v2); n = (*opt2PtrPtr)->opt_level - (*opt1PtrPtr)->opt_level; if (n == 0) n = (*opt2PtrPtr)->opt_name - (*opt1PtrPtr)->opt_name; CAMLreturn(n); } static long cf_socket_option_hash(value v) { CAMLparam1(v); long n; const Cf_socket_option_t** optPtrPtr; optPtrPtr = Cf_socket_option_val(v); n = (long) *optPtrPtr; CAMLreturn(Val_int(n)); } static struct custom_operations cf_socket_option_op = { "org.conjury.ocnae.cf.socket_option", custom_finalize_default, cf_socket_option_compare, cf_socket_option_hash, custom_serialize_default, custom_deserialize_default }; value cf_socket_option_alloc(const Cf_socket_option_t* ptr) { value optVal; optVal = alloc_custom(&cf_socket_option_op, sizeof ptr, 0, 1); *Cf_socket_option_val(optVal) = ptr; return optVal; } void cf_socket_getsockopt_guard (const Cf_socket_option_context_t* contextPtr, void* optval, socklen_t* optlen) { int result; result = getsockopt (contextPtr->xopt_fd, contextPtr->xopt_level, contextPtr->xopt_name, optval, optlen); if (result) uerror("getsockopt", Nothing); } void cf_socket_setsockopt_guard (const Cf_socket_option_context_t* contextPtr, const void* optval, socklen_t optlen) { int result; result = setsockopt (contextPtr->xopt_fd, contextPtr->xopt_level, contextPtr->xopt_name, optval, optlen); if (result) uerror("setsockopt", Nothing); } value cf_socket_getsockopt_bool (const Cf_socket_option_context_t* contextPtr) { int optval; socklen_t optlen; optval = 0; optlen = sizeof optval; cf_socket_getsockopt_guard(contextPtr, &optval, &optlen); return optval ? Val_true : Val_false; } void cf_socket_setsockopt_bool (const Cf_socket_option_context_t* contextPtr, value x) { int optval; optval = Bool_val(x); cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval); } value cf_socket_getsockopt_int (const Cf_socket_option_context_t* contextPtr) { int optval; socklen_t optlen; optval = 0; optlen = sizeof optval; cf_socket_getsockopt_guard(contextPtr, &optval, &optlen); return Val_int(optval); } void cf_socket_setsockopt_int (const Cf_socket_option_context_t* contextPtr, value x) { int optval; optval = Int_val(x); cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval); } value cf_socket_getsockopt_linger (const Cf_socket_option_context_t* contextPtr) { struct linger optval; socklen_t optlen; value result; memset(&optval, 0, sizeof optval); optlen = sizeof optval; cf_socket_getsockopt_guard(contextPtr, &optval, &optlen); if (optval.l_onoff) { result = alloc_small(1, 0); Store_field(result, 0, Val_int(optval.l_linger)); } else result = Val_int(0); return result; } void cf_socket_setsockopt_linger (const Cf_socket_option_context_t* contextPtr, value x) { struct linger optval; memset(&optval, 0, sizeof optval); optval.l_onoff = Is_block(x); if (optval.l_onoff) optval.l_linger = Int_val(Field(x, 0)); cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval); } value cf_socket_getsockopt_timeout (const Cf_socket_option_context_t* contextPtr) { struct timeval optval; socklen_t optlen; double dt; value result; memset(&optval, 0, sizeof optval); optlen = sizeof optval; cf_socket_getsockopt_guard(contextPtr, &optval, &optlen); dt = (double) optval.tv_sec + (double) optval.tv_usec / 1E6; return copy_double(dt); } void cf_socket_setsockopt_timeout (const Cf_socket_option_context_t* contextPtr, value x) { struct timeval optval; double dt; dt = Double_val(x); optval.tv_sec = (int) dt; optval.tv_usec = (int)(1E6 * (dt - optval.tv_sec)); cf_socket_setsockopt_guard(contextPtr, &optval, sizeof optval); } value cf_socket_getsockopt_error (const Cf_socket_option_context_t* contextPtr) { int optval; socklen_t optlen; memset(&optval, 0, sizeof optval); optlen = sizeof optval; cf_socket_getsockopt_guard(contextPtr, &optval, &optlen); if (optval) unix_error(optval, "getsockopt", Nothing); return Val_unit; } /*--- external getsockopt: ('af,'st) t -> 'v untagged_sockopt_t -> 'v = "cf_socket_getsockopt" ---*/ CAMLprim value cf_socket_getsockopt(value sockVal, value optVal) { CAMLparam2(sockVal, optVal); CAMLlocal1(resultVal); const Cf_socket_option_t** optPtrPtr; const Cf_socket_t* sockPtr; Cf_socket_option_context_t xopt; Cf_socket_getsockopt_f getF; sockPtr = Cf_socket_val(sockVal); optPtrPtr = Cf_socket_option_val(optVal); getF = (*optPtrPtr)->opt_get; if (!getF) { char failStr[80]; sprintf(failStr, "Cf_socket.getsockopt %s not implemented.", (*optPtrPtr)->opt_name_str); failwith(failStr); } xopt.xopt_fd = sockPtr->s_fd; xopt.xopt_level = (*optPtrPtr)->opt_level; xopt.xopt_name = (*optPtrPtr)->opt_name; resultVal = getF(&xopt); CAMLreturn(resultVal); } /*--- external setsockopt: ('af,'st) t -> 'v untagged_sockopt_t -> 'v -> unit = "cf_socket_setsockopt" ---*/ CAMLprim void cf_socket_setsockopt(value sockVal, value optVal, value setVal) { CAMLparam3(sockVal, optVal, setVal); const Cf_socket_option_t** optPtrPtr; const Cf_socket_t* sockPtr; Cf_socket_option_context_t xopt; Cf_socket_setsockopt_f setF; sockPtr = Cf_socket_val(sockVal); optPtrPtr = Cf_socket_option_val(optVal); setF = (*optPtrPtr)->opt_set; if (!setF) { char failStr[80]; sprintf(failStr, "Cf_socket.setsockopt %s not implemented.", (*optPtrPtr)->opt_name_str); failwith(failStr); } xopt.xopt_fd = sockPtr->s_fd; xopt.xopt_level = (*optPtrPtr)->opt_level; xopt.xopt_name = (*optPtrPtr)->opt_name; setF(&xopt, setVal); CAMLreturn0; } /*--- type sockopt_index_t = SO_DEBUG | SO_REUSEADDR | SO_REUSEPORT | SO_KEEPALIVE | SO_DONTROUTE | SO_LINGER | SO_BROADCAST | SO_OOBINLINE | SO_SNDBUF | SO_RCVBUF | SO_SNDLOWAT | SO_RCVLOWAT | SO_SNDTIMEO | SO_RCVTIMEO | SO_ERROR | SO_NOSIGPIPE ---*/ static Cf_socket_sockopt_lift_t cf_socket_sockopt_lift_array[] = { { /* SO_DEBUG */ Val_unit, { SOL_SOCKET, SO_DEBUG, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } }, { /* SO_REUSEADDR */ Val_unit, { SOL_SOCKET, SO_REUSEADDR, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } }, #ifdef SO_REUSEPORT { /* SO_REUSEPORT */ Val_unit, { SOL_SOCKET, SO_REUSEPORT, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } }, #else { /* SO_REUSEPORT */ Val_unit, { } }, #endif { /* SO_KEEPALIVE */ Val_unit, { SOL_SOCKET, SO_KEEPALIVE, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } }, { /* SO_DONTROUTE */ Val_unit, { SOL_SOCKET, SO_DONTROUTE, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } }, { /* SO_LINGER */ Val_unit, { SOL_SOCKET, SO_LINGER, cf_socket_getsockopt_linger, cf_socket_setsockopt_linger } }, { /* SO_BROADCAST */ Val_unit, { SOL_SOCKET, SO_BROADCAST, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } }, { /* SO_OOBINLINE */ Val_unit, { SOL_SOCKET, SO_OOBINLINE, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } }, { /* SO_SNDBUF */ Val_unit, { SOL_SOCKET, SO_SNDBUF, cf_socket_getsockopt_int, cf_socket_setsockopt_int } }, { /* SO_RCVBUF */ Val_unit, { SOL_SOCKET, SO_RCVBUF, cf_socket_getsockopt_int, cf_socket_setsockopt_int } }, { /* SO_SNDLOWAT */ Val_unit, { SOL_SOCKET, SO_SNDLOWAT, cf_socket_getsockopt_int, cf_socket_setsockopt_int } }, { /* SO_RCVLOWAT */ Val_unit, { SOL_SOCKET, SO_RCVLOWAT, cf_socket_getsockopt_int, cf_socket_setsockopt_int } }, { /* SO_SNDTIMEO */ Val_unit, { SOL_SOCKET, SO_SNDTIMEO, cf_socket_getsockopt_timeout, cf_socket_setsockopt_timeout } }, { /* SO_RCVTIMEO */ Val_unit, { SOL_SOCKET, SO_RCVTIMEO, cf_socket_getsockopt_timeout, cf_socket_setsockopt_timeout } }, { /* SO_ERROR */ Val_unit, { SOL_SOCKET, SO_ERROR, cf_socket_getsockopt_error, cf_socket_setsockopt_bool } }, #ifdef SO_NOSIGPIPE { /* SO_NOSIGPIPE */ Val_unit, { SOL_SOCKET, SO_NOSIGPIPE, cf_socket_getsockopt_bool, cf_socket_setsockopt_bool } } #else { /* SO_NOSIGPIPE */ Val_unit, { } } #endif }; #define CF_SOCKET_SOCKOPT_LIFT_ARRAY_SIZE \ (sizeof cf_socket_sockopt_lift_array / \ sizeof cf_socket_sockopt_lift_array[0]) /*--- external sockopt_lift: sockopt_index_t -> ('a, 'b, 'c) sockopt_t = "cf_socket_sockopt_lift" ---*/ CAMLprim value cf_socket_sockopt_lift(value indexVal) { CAMLparam1(indexVal); CAMLreturn(cf_socket_sockopt_lift_array[Int_val(indexVal)].ol_val); } /*--- Initialization primitive ---*/ CAMLprim value cf_socket_init(value unit) { int i; register_custom_operations(&cf_socket_op); register_custom_operations(&cf_socket_option_op); for (i = 0; i < CF_SOCKET_SOCKOPT_LIFT_ARRAY_SIZE; ++i) { Cf_socket_sockopt_lift_t* liftPtr; liftPtr = &cf_socket_sockopt_lift_array[i]; register_global_root(&liftPtr->ol_val); liftPtr->ol_val = cf_socket_option_alloc(&liftPtr->ol_option); } return Val_unit; } /*--- End of File [ cf_socket_p.c ] ---*/ cf-0.10/cf_socket_p.h0000644000175000017500000001275710404616701014361 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_socket_p.h Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_SOCKET_P_H #define _CF_SOCKET_P_H #include "cf_common_p.h" #include #include #include #define Cf_socket_sockaddrx_struct(suffix) \ struct cf_socket_sockaddrx_##suffix##_s { \ size_t sx_socklen; \ struct sockaddr_##suffix sx_sockaddr_##suffix; \ } #define Cf_socket_sockaddrx_t(suffix) Cf_socket_sockaddrx_##suffix##_t #define Cf_socket_sockaddrx_typedef(suffix) \ typedef struct cf_socket_sockaddrx_##suffix##_s Cf_socket_sockaddrx_t(suffix) #define Cf_socket_sockaddrx_val(suffix, v) \ ((Cf_socket_sockaddrx_t(suffix)*) Data_custom_val(v)) Cf_socket_sockaddrx_struct(storage); Cf_socket_sockaddrx_typedef(storage); struct cf_socket_sockaddrx_unit_s { size_t sx_socklen; struct sockaddr sx_sockaddr; }; typedef struct cf_socket_sockaddrx_unit_s Cf_socket_sockaddrx_unit_t; #define Cf_socket_sockaddrx_unit_val(v) \ ((Cf_socket_sockaddrx_unit_t*) Data_custom_val(v)) typedef value (*Cf_socket_sockaddrx_cons_f) (const struct sockaddr* saPtr, size_t saLen); struct cf_socket_domain_s { int d_domain; /* PF_INET, PF_LOCAL, ... */ int d_family; /* AF_INET, AF_LOCAL, ... */ Cf_socket_sockaddrx_cons_f d_consaddr; /* sockaddr alloc function */ size_t d_socklen; /* sizeof(sockaddr_xxx) */ }; typedef struct cf_socket_domain_s Cf_socket_domain_t; #define Cf_socket_domain_val(v) ((Cf_socket_domain_t*) Data_custom_val(v)) extern value cf_socket_domain_alloc(const Cf_socket_domain_t* ptr); struct cf_socket_s { int s_fd; int s_socktype; int s_protocol; Cf_socket_domain_t s_domain; }; typedef struct cf_socket_s Cf_socket_t; #define Cf_socket_val(v) ((Cf_socket_t*) Data_custom_val(v)) extern value cf_socket_alloc (int fd, int socktype, int protocol, const Cf_socket_domain_t* domainPtr); extern int cf_socket_msg_flags_to_int(value flagsVal); extern value cf_socket_msg_flags_of_int(int flags); struct cf_socket_option_context_s { int xopt_fd; int xopt_level; int xopt_name; }; typedef struct cf_socket_option_context_s Cf_socket_option_context_t; typedef value (*Cf_socket_getsockopt_f) (const Cf_socket_option_context_t* contextPtr); typedef void (*Cf_socket_setsockopt_f) (const Cf_socket_option_context_t* contextPtr, value x); struct cf_socket_option_s { int opt_level; int opt_name; Cf_socket_getsockopt_f opt_get; Cf_socket_setsockopt_f opt_set; const char* opt_name_str; }; typedef struct cf_socket_option_s Cf_socket_option_t; struct cf_socket_sockopt_lift_s { value ol_val; const Cf_socket_option_t ol_option; }; typedef struct cf_socket_sockopt_lift_s Cf_socket_sockopt_lift_t; #define Cf_socket_option_val(v) \ ((const Cf_socket_option_t**) Data_custom_val(v)) extern value cf_socket_option_alloc(const Cf_socket_option_t* ptr); extern void cf_socket_getsockopt_guard (const Cf_socket_option_context_t* contextPtr, void* optval, socklen_t* optlen); extern void cf_socket_setsockopt_guard (const Cf_socket_option_context_t* contextPtr, const void* optval, socklen_t optlen); extern value cf_socket_getsockopt_bool (const Cf_socket_option_context_t* contextPtr); extern void cf_socket_setsockopt_bool (const Cf_socket_option_context_t* contextPtr, value x); extern value cf_socket_getsockopt_int (const Cf_socket_option_context_t* contextPtr); extern void cf_socket_setsockopt_int (const Cf_socket_option_context_t* contextPtr, value x); extern value cf_socket_getsockopt_int_option (const Cf_socket_option_context_t* contextPtr); extern void cf_socket_setsockopt_int_option (const Cf_socket_option_context_t* contextPtr, value x); extern value cf_socket_getsockopt_float (const Cf_socket_option_context_t* contextPtr); extern void cf_socket_setsockopt_float (const Cf_socket_option_context_t* contextPtr, value x); #endif /* defined(_CF_SOCKET_P_H) */ /*--- End of File [ cf_socket_p.h ] ---*/ cf-0.10/cf_state_gadget.ml0000644000175000017500000002074710731665257015401 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_state_gadget.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) type ('i, 'o) kernel = { k_writeQ_: 'o Queue.t; k_workQ_: (('i, 'o) kernel -> unit) Queue.t; k_readQ_: ('i -> unit) Queue.t; mutable k_wireN_: int; } type ('x, 'i, 'o) rx0 = { rx0_txPtr_: ('x, 'i, 'o) tx0 Weak.t; rx0_pendQ_: 'x Queue.t; } and ('x, 'i, 'o) tx0 = { tx0_rxPtr_: ('x, 'i, 'o) rx0 Weak.t; tx0_gateQ_: ('x, 'i, 'o) guard0 Queue.t; } and ('x, 'i, 'o) guard0 = { x0_txLst_: (Obj.t, 'i, 'o) tx0 list; x0_getF_: 'x -> ('i, 'o) kernel -> unit; } type ('x, 'i, 'o) gate0 = { y0_rx_: ('x, 'i, 'o) rx0; y0_getF_: 'x -> ('i, 'o) kernel -> unit; } type ('x, 'i, 'o) wire = (('x, 'i, 'o) rx0 * ('x, 'i, 'o) tx0) option * string Lazy.t let kernel_ () = { k_writeQ_ = Queue.create (); k_workQ_ = Queue.create (); k_readQ_ = Queue.create (); k_wireN_ = 0; } let rx0_ () = { rx0_txPtr_ = Weak.create 1; rx0_pendQ_ = Queue.create (); } let tx0_ () = { tx0_rxPtr_ = Weak.create 1; tx0_gateQ_ = Queue.create (); } let null = None, (Lazy.lazy_from_val "wire[null]") let rec scheduler_ k = if Queue.is_empty k.k_writeQ_ then if Queue.is_empty k.k_workQ_ then if Queue.is_empty k.k_readQ_ then Cf_flow.Z else let q = Queue.take k.k_readQ_ in Cf_flow.Q (fun i -> q i; scheduler_ k) else let () = Queue.take k.k_workQ_ k in scheduler_ k else Cf_flow.P (Queue.take k.k_writeQ_, lazy (scheduler_ k)) type ('s, 'i, 'o) work = ('i, 'o) kernel -> ('s -> unit) -> 's -> unit type ('s, 'i, 'o) gate = ('s -> (Obj.t, 'i, 'o) gate0) Cf_seq.t type ('s, 'i, 'o, 'a) guard = (('s, 'i, 'o) gate, 'a) Cf_cmonad.t type ('s, 'i, 'o, 'a) t = (('s, 'i, 'o) work, 'a) Cf_cmonad.t let work_ m s k = m (fun () _ f s -> f s) k (fun _ -> ()) s let eval m s = let k = kernel_ () in work_ m s k; lazy (scheduler_ k) let start m s c k = Queue.add (work_ m s) k.k_workQ_; c () k let pushGuard_ txLst (tx0, getF) = Queue.add { x0_txLst_ = txLst; x0_getF_ = getF } tx0.tx0_gateQ_ let rec match1_ k txLst gLst z = match Lazy.force z with | Cf_seq.Z -> List.iter (pushGuard_ txLst) gLst | Cf_seq.P (y0, z) -> let { y0_rx_ = rx0; y0_getF_ = getF } = y0 in match Weak.get rx0.rx0_txPtr_ 0 with | None -> match1_ k txLst gLst z | Some tx0 -> match try Some (Queue.take rx0.rx0_pendQ_) with Queue.Empty -> None with | Some obj -> Queue.add (getF obj) k.k_workQ_ | None -> match1_ k (tx0 :: txLst) ((tx0, getF) :: gLst) z let guard m _ k _ s = match1_ k [] [] (Cf_seq.map (fun g -> g s) (Cf_seq.evalC m)) let abort _ _ _ _ = () let id_ n = lazy (Printf.sprintf "%08u" n) let wire c k = let n = succ k.k_wireN_ in k.k_wireN_ <- n; let id = id_ n in let rx = rx0_ () and tx = tx0_ () in Weak.set tx.tx0_rxPtr_ 0 (Some rx); Weak.set rx.rx0_txPtr_ 0 (Some tx); c (Some (rx, tx), id) k let wirepair c k = let n0 = succ k.k_wireN_ in let n1 = succ n0 in k.k_wireN_ <- n1; let idA = id_ n0 and idB = id_ n1 in let rxA = rx0_ () and rxB = rx0_ () in let txA = tx0_ () and txB = tx0_ () in Weak.set rxA.rx0_txPtr_ 0 (Some txA); Weak.set rxB.rx0_txPtr_ 0 (Some txB); Weak.set txA.tx0_rxPtr_ 0 (Some rxA); Weak.set txB.tx0_rxPtr_ 0 (Some rxB); c ((Some (rxA, txA), idA), (Some (rxB, txB), idB)) k class type connector = object method check: bool method id: string end class ['x, 'i, 'o] rx (w, id : ('x, 'i, 'o) wire) = let rx0 = match w with | Some (rx0, _) -> rx0 | None -> rx0_ () in object val rx0_ = rx0 method id = Lazy.force id method check = Weak.check rx0_.rx0_txPtr_ 0 method get: 's. ('x -> ('s, 'i, 'o, unit) t) -> ('s, 'i, 'o, unit) guard = fun f -> if Weak.check rx0_.rx0_txPtr_ 0 then begin Cf_seq.writeC begin fun s -> let g obj = work_ (f obj) s in Obj.magic { y0_rx_ = rx0; y0_getF_ = g } end end else begin Queue.clear rx0_.rx0_pendQ_; Cf_cmonad.nil end end class ['x, 'i, 'o] tx (w, id : ('x, 'i, 'o) wire) = let tx0 = match w with | Some (_, tx0) -> tx0 | None -> tx0_ () in object val tx0_ = tx0 method id = Lazy.force id method check = Weak.check tx0_.tx0_rxPtr_ 0 method put: 's. 'x -> ('s, 'i, 'o, unit) t = fun obj c k f s -> begin match try Some (Queue.take tx0.tx0_gateQ_) with Queue.Empty -> None with | Some x0 -> let x0: (Obj.t, 'i, 'o) guard0 = Obj.magic x0 in let obj = Obj.repr obj in List.iter begin fun tx0 -> let q = Queue.create () in Queue.iter begin fun x0' -> if x0'.x0_txLst_ != x0.x0_txLst_ then Queue.add x0' q end tx0.tx0_gateQ_; Queue.clear tx0.tx0_gateQ_; Queue.transfer q tx0.tx0_gateQ_ end x0.x0_txLst_; Queue.add (x0.x0_getF_ obj) k.k_workQ_ | None -> match Weak.get tx0_.tx0_rxPtr_ 0 with | None -> Queue.clear tx0_.tx0_gateQ_ | Some rx0 -> Queue.add obj rx0.rx0_pendQ_ end; Queue.add (fun _ -> c () k f s) k.k_workQ_ end let simplex c = wire (fun w -> c (new rx w, new tx w)) type ('x, 'y, 'i, 'o) pad = ('x, 'i, 'o) rx * ('y, 'i, 'o) tx type ('x, 'y, 'i, 'o) fix = ('y, 'i, 'o) rx * ('x, 'i, 'o) tx let duplex c = wirepair (fun (a, b) -> c ((new rx a, new tx b), (new rx b, new tx a))) let read c k f s = Queue.add (fun i -> c i k f s) k.k_readQ_ let write x c k f s = Queue.add x k.k_writeQ_; Queue.add (fun _ -> c () k f s) k.k_workQ_ let load c k f s = (c s) k f s let store s c k f _ = c () k f s let modify g c k f s = c () k f (g s) open Cf_cmonad.Op let wrap x y = let x = (x :> ('x, 'i, 'o) rx) in let y = (y :> ('y, 'i, 'o) tx) in let rec loop w = match Lazy.force w with | Cf_flow.Z -> Cf_cmonad.nil | Cf_flow.P (hd, tl) -> y#put hd >>= fun () -> loop tl | Cf_flow.Q f -> guard (x#get (fun obj -> loop (lazy (f obj)))) in fun w -> start (loop w) () (*--- End of File [ cf_state_gadget.ml ] ---*) cf-0.10/cf_state_gadget.mli0000644000175000017500000002345210731665257015546 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_state_gadget.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** Monadic composition of complex stream processors. An experimental interface for constructing interactive functional systems in a single thread of control. *) (** {6 Overview} This module implements a marginally more general version of the Gadget system described in Chapter 30 of Magnus Carlsson's and Thomas Hallgren's joint {{:http://www.cs.chalmers.se/~hallgren/Thesis/}Ph.D. thesis}. In the context of this module, a "gadget" is a monad that evaluates into a {!Cf_flow} object, capable of alternately reading from a source of input values and writing to a sink of output values. The continuation monad is specialized over an abstract "process" monad type, and a scheduler handles the calls and jumps between multiple simultaneous processes communicating with one another over a very lightweight message passing abstraction called a "wire". The abstract process monad is a kind of state-continuation monad for operations over the internal {!Cf_flow} value. The operations it supports are lifted into the gadget monad, as are briefly sumamrized as follows: {ul {- {i start}: launch a new process in the scheduler.} {- {i wire}: create a new message wire.} {- {i put}: send a message on a wire.} {- {i get}: create a gate for receiving messages on a wire.} {- {i guard}: receive a message from one of several gates.} {- {i load}: load the current process state.} {- {i store}: store a new value of the process state.} {- {i read}: read a new value from the external input.} {- {i write}: write a new value to the external output.} } 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 can easily manipulate this encapsulated state. When a process has no more messages to receive or transmit, the scheduler reclaims its resources and the final state is discarded. Any process may read from the internal input stream or write to the external output stream. Conventionally, it is often simpler to define a a reader process and a writer process to localize these effects. {b Note}: see Magnus Carlsson's and Thomas Hallgren's joint {{:http://www.cs.chalmers.se/~hallgren/Thesis/}Ph.D. thesis} for a complete dissertation on the nature of the system of concepts behind this module. *) (** {6 Types} *) (** An functionally compositional unit of work in a gadget. It encapsulates the state-continuation monad for a work loop. *) type ('s, 'i, 'o) work (** A gate for receiving messages in a process of type [('s, 'i, 'o) work] using the [guard] function. *) type ('s, 'i, 'o) gate (** An object capable of delivering messages of type ['x] from a sender to a a receiver in a [('s, 'i, 'o) work] continuation. *) type ('x, 'i, 'o) wire (** A guard for receiving a message from one or more sources. *) type ('s, 'i, 'o, 'a) guard = (('s, 'i, 'o) gate, 'a) Cf_cmonad.t (** A continuation monad parameterized by process type. *) type ('s, 'i, 'o, 'a) t = (('s, 'i, 'o) work, 'a) Cf_cmonad.t (** {6 Functions} *) (** Use [eval y s] to obtain a new flow by evaluating the gadget monad [y] with a state initializer of [a]. *) val eval: ('s, 'i, 'o, unit) t -> 's -> ('i, 'o) Cf_flow.t (** Bind the result of [start y s] to start a new process evaluating the gadget [y] with a state initializer [s]. *) val start: ('s0, 'i, 'o, unit) t -> 's0 -> ('s1, 'i, 'o, unit) t (** Use [guard m] to receive the next message guarded by [m]. Control will pass to the continuation of the first gate in the guard to receive a message. If no gates in the guard are able to receive a message, i.e. the guard is either empty or all of the gates are on wires that have no transmitters anymore, then control is returned to the scheduler. *) val guard: ('s, 'i, 'o, unit) guard -> ('s, 'i, 'o, 'a) t (** Use [abort] to abort processing and return to the scheduler. Control will not be passed to any continuation bound to the result. *) val abort: ('s, 'i, 'o, 'a) t (** Use [wire] to return a new wire for carrying messages of type ['x]. *) val wire: ('s, 'i, 'o, ('x, 'i, 'o) wire) t (** Use [wirepair] to return a pair of new wires for carrying messages of type ['x] and ['y]. *) val wirepair: ('s, 'i, 'o, ('x, 'i, 'o) wire * ('y, 'i, 'o) wire) 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: ('x, 'i, 'o) wire (** Bind [read] to get the next input value from the external stream. *) val read: ('s, 'i, 'o, 'i) t (** Bind the result of [write obj] to put the next output value into the external stream. *) val write: 'o -> ('s, 'i, 'o, unit) t (** Bind [load] to get the current state encapsulated in the process. *) val load: ('s, 'i, 'o, 's) t (** Bind the result of [store obj] to store the state [obj] as the encapsulated state for the current monad. *) val store: 's -> ('s, 'i, 'o, unit) t (** Bind the result of [modify f] to apply [f] to the current encapsulated state of the process and store the resulting new state. *) val modify: ('s -> 's) -> ('s, 'i, 'o, unit) t (** {6 Classes} *) (** The class type of connector objects. *) class type connector = object (** 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 ['x, 'i, 'o] rx: ('x, 'i, 'o) wire -> (** A wire carrying messages of type ['x]. *) object 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. ('x -> ('s, 'i, 'o, unit) t) -> ('s, 'i, 'o, unit) guard end (** The class of transmitter objects. *) class ['x, 'i, 'o] tx: ('x, 'i, 'o) wire -> (** A wire carrying messages of type ['x]. *) object inherit connector (** Use [tx#put obj] to schedule the message obj for deliver on the associated wire. *) method put: 's. 'x -> ('s, 'i, 'o, unit) t end (** {6 Miscellaneous} *) (** Use [simplex] to construct a new maching pair of [rx] and [tx] objects.*) val simplex: ('s, 'i, 'o, ('x, 'i, 'o) rx * ('x, 'i, 'o) tx) t (** A pair of convenience types for representing each end of a bundle of two wires used for duplex communication. *) type ('x, 'y, 'i, 'o) pad = ('x, 'i, 'o) rx * ('y, 'i, 'o) tx type ('x, 'y, 'i, 'o) fix = ('y, 'i, 'o) rx * ('x, 'i, 'o) tx (** Use [duplex] to construct a new duplex communication channel, composed of two wires each in opposite flow. A matching head and tail of the channel is returned. *) val duplex: ('s, 'i, 'o, ('x, 'y, 'i, 'o) pad * ('x, 'y, 'i, 'o) fix) 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 to the flow (copying it from the [rx] object). *) val wrap: ('x, 'i, 'o) #rx -> ('y, 'i, 'o) #tx -> ('x, 'y) Cf_flow.t -> ('s, 'i, 'o, unit) t (*--- End of File [ cf_state_gadget.mli ] ---*) cf-0.10/cf_stdtime.ml0000644000175000017500000001005410433520573014373 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_stdtime.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) type t = { year: int; (* -2937947 .. 2941664, 1 BC = 0 *) month: int; (* january=1 .. december=12 *) day: int; (* 1 .. 31 *) hour: int; (* 0 .. 23 *) minute: int; (* 0 .. 59 *) second: int; (* 0 .. 60, 60=leap second *) } let sixty_ = Int64.of_int 60 let magic58486_ = Int64.of_int 58486 let magic53375995543064_ = Int64.of_string "53375995543064" let secs_per_day_ = Int64.of_int 86400 let utc_of_tai64 ?wday ?yday mark = let leap, mark = Cf_tai64.leapsec_sub mark in let u = Cf_tai64.sub mark Cf_tai64.first in let u = Int64.add u magic58486_ in let s = Int64.rem u secs_per_day_ in let second = if leap then 60 else (Int64.to_int (Int64.rem s sixty_)) in let s = Int64.div s sixty_ in let minute = (Int64.to_int (Int64.rem s sixty_)) in let s = Int64.div s sixty_ in let hour = Int64.to_int s in let u = Int64.div u secs_per_day_ in let u = Int64.sub u magic53375995543064_ in let mjd = Int64.to_int u in let year, month, day = Cf_gregorian.of_mjd ?wday ?yday mjd in { year = year; month = month; day = day; hour = hour; minute = minute; second = second; } let utc_to_tai64_unsafe ~year ~month ~day ~hour ~minute ~second = let sec = ((((hour * 60) + minute)) * 60) + second in let mjd = Cf_gregorian.to_mjd ~year ~month ~day in let s64 = Int64.mul (Int64.of_int mjd) secs_per_day_ in let s64 = Int64.add s64 (Int64.of_int sec) in let tai = Cf_tai64.add_int64 Cf_tai64.mjd_epoch s64 in Cf_tai64.leapsec_add tai (second = 60) let utc_to_tai64 ~year ~month ~day ~hour ~minute ~second = if not (Cf_gregorian.is_valid ~year ~month ~day) then invalid_arg "Cf_stdtime.utc_to_tai64: not valid gregorian date."; if hour < 0 || hour > 23 || minute < 0 || minute > 59 || second < 0 || second > 60 then invalid_arg "Cf_stdtime.utc_to_tai64: not valid wallclock time."; let sec = ((((hour * 60) + minute)) * 60) + second in let mjd = Cf_gregorian.to_mjd ~year ~month ~day in let s64 = Int64.mul (Int64.of_int mjd) secs_per_day_ in let s64 = Int64.add s64 (Int64.of_int sec) in let tai = Cf_tai64.add_int64 Cf_tai64.mjd_epoch s64 in if second < 60 then Cf_tai64.leapsec_add tai false else let v = Cf_tai64.leapsec_add tai true in let leap, _ = Cf_tai64.leapsec_sub tai in if not leap then invalid_arg "Cf_stdtime.utc_to_tai64: unrecorded leap second."; v (*--- End of File [ cf_stdtime.ml ] ---*) cf-0.10/cf_stdtime.mli0000644000175000017500000000774610433520573014562 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_stdtime.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** Conversions between Standard Time, UTC and TAI. *) (** {6 Overview} *) (** This module contains a type for representing values of standard time, defined as a reference from Coordinated Universal Time (UTC). It also provides functions for converting values of standard time to and from TAI64 values (see {!Cf_tai64}). {b Note:} no facility is yet provided here for manipulating time with associated timezone attributes. Converting arbitrary values of UTC time to and from local time is tricky, since daylight savings time rules vary greatly from locality to locality and also over time. {b Warning!} The International Earth Rotation and Reference System Service determines whether and when to insert or delete leap seconds into the UTC timescale. These announcements are made every six months in an IERS bulletin. The current implementation contains a hard-coded table of leap seconds that was accurate at least until Jan 1, 2007. *) (** {6 Types} *) (** A record with field for each component of a standard time value. *) type t = { year: int; (** -2937947 .. 2941664, 1 BC == 0 *) month: int; (** january=1 .. december=12 *) day: int; (** 1 .. 31 *) hour: int; (** 0 .. 23 *) minute: int; (** 0 .. 59 *) second: int; (** 0 .. 60, 60=leap second *) } (** {6 Functions} *) (** Convert from TAI64 to UTC time. Use [utc_of_tai64 ~wday ~yday tai] to obtain a UTC standard time record corresponding to the TAI time index [tai]. Optionally, if ~wday and/or ~yday are provided, this function stores the day of the week (0=sunday,6=saturday) in [wday] and the day of year (1..366) in [yday]. *) val utc_of_tai64: ?wday:int ref -> ?yday:int ref -> Cf_tai64.t -> t (** Convert from UTC time to TAI64. Use [utc ~year ~month ~day ~hour ~minute ~sec] to obtain a TAI64 value corresponding to the UTC standard time specified by the [~year ~month ~day ~hour ~minute ~sec] arguments. Raises [Invalid_argument] if the time specified is not a valid UTC time value. *) val utc_to_tai64: year:int -> month:int -> day:int -> hour:int -> minute:int -> second:int -> Cf_tai64.t (** This is the same as [utc_to_tai64], except it assumes the input is a valid UTC time value. If it isn't, then the result is undefined. *) val utc_to_tai64_unsafe: year:int -> month:int -> day:int -> hour:int -> minute:int -> second:int -> Cf_tai64.t (*--- End of File [ cf_stdtime.mli ] ---*) cf-0.10/cf_tai64.ml0000644000175000017500000001326510433520573013660 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_tai64.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) type t exception Range_error exception Label_error external compare: t -> t -> int = "cf_tai64_compare" external now: unit -> t = "cf_tai64_now" external epoch_: unit -> t = "cf_tai64_epoch" external first_: unit -> t = "cf_tai64_first" external last_: unit -> t = "cf_tai64_last" external mjd_epoch_: unit -> t = "cf_tai64_mjd_epoch" external set_current_offset_: int -> unit = "cf_tai64_set_current_offset" external to_unix_time: t -> float = "cf_tai64_to_unix_time" external of_unix_time: float -> t = "cf_tai64_of_unix_time" external to_label: t -> string = "cf_tai64_to_label" external of_label: string -> t = "cf_tai64_of_label" external add: t -> int -> t = "cf_tai64_add_int" external add_int32: t -> int32 -> t = "cf_tai64_add_int32" external add_int64: t -> int64 -> t = "cf_tai64_add_int64" external sub: t -> t -> int64 = "cf_tai64_sub" ;; external init_: unit -> unit = "cf_tai64_init";; let _ = Callback.register_exception "Cf_tai64.Range_error" Range_error;; init_ ();; let epoch = epoch_ () let first = first_ () let last = last_ () let mjd_epoch = mjd_epoch_ () type archive_t = { a_current_: int; a_history_: (t * int) list; a_expires_: t; } (*--- This data is copied manually copied from the NIST leap seconds archive. Yes, this really shouldn't be hard-coded. Perhaps, there is a way to retrieve this information from an NTP client application. ---*) let embedded_ = "3360441600", [ "2272060800", 10; (* 1 Jan 1972 *) "2287785600", 11; (* 1 Jul 1972 *) "2303683200", 12; (* 1 Jan 1973 *) "2335219200", 13; (* 1 Jan 1974 *) "2366755200", 14; (* 1 Jan 1975 *) "2398291200", 15; (* 1 Jan 1976 *) "2429913600", 16; (* 1 Jan 1977 *) "2461449600", 17; (* 1 Jan 1978 *) "2492985600", 18; (* 1 Jan 1979 *) "2524521600", 19; (* 1 Jan 1980 *) "2571782400", 20; (* 1 Jul 1981 *) "2603318400", 21; (* 1 Jul 1982 *) "2634854400", 22; (* 1 Jul 1983 *) "2698012800", 23; (* 1 Jul 1985 *) "2776982400", 24; (* 1 Jan 1988 *) "2840140800", 25; (* 1 Jan 1990 *) "2871676800", 26; (* 1 Jan 1991 *) "2918937600", 27; (* 1 Jul 1992 *) "2950473600", 28; (* 1 Jul 1993 *) "2982009600", 29; (* 1 Jul 1994 *) "3029443200", 30; (* 1 Jan 1996 *) "3076704000", 31; (* 1 Jul 1997 *) "3124137600", 32; (* 1 Jan 1999 *) "3345062400", 33; (* 1 Jan 2006 *) ] let archive_ = let tai64_1900 = Int64.of_string "0x3fffffff7c55818a" in let tai64_1900 = add_int64 first tai64_1900 in let rec loop dt0 adj acc = function | (_, dt) :: tl when dt0 = dt -> loop dt0 adj acc tl | (secs, dt) :: tl -> let secs = Int64.of_string secs in let tai64 = add_int64 tai64_1900 secs in let tai64 = add tai64 adj in loop dt (adj + (dt - dt0)) ((tai64, dt0) :: acc) tl | [] -> dt0, acc in let expires, history = embedded_ in let current, history = loop 10 0 [] history in let expires = add_int64 tai64_1900 (Int64.of_string expires) in let expires = add expires current in set_current_offset_ current; ref { a_current_ = current; a_history_ = history; a_expires_ = expires; } let leapsec_add = let rec loop mark hit dt = function | (tai, dt') :: tl -> let mark' = add mark (10 - dt') in let cmp = compare tai mark' in if cmp < 0 || hit && cmp = 0 then loop mark hit dt' tl else dt | _ -> dt in fun mark hit -> let a = !archive_ in let dt = loop mark hit a.a_current_ a.a_history_ in add mark (dt - 10) let leapsec_sub = let rec loop mark dt = function | (tai, dt) :: tl when (compare tai mark < 0) -> loop mark dt tl | (tai, _) :: _ when (compare tai mark = 0) -> true, dt | _ -> false, dt in fun mark -> let a = !archive_ in let leap, dt = loop mark a.a_current_ a.a_history_ in leap, add mark (10 - dt) (*--- End of File [ cf_tai64.ml ] ---*) cf-0.10/cf_tai64.mli0000644000175000017500000001302410456202024014013 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_tai64.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** Computations with the Temps Atomique International (TAI) timescale. *) (** {6 Overview} This module defines an abstract type and associated functions for computations with values representing epochs in the Temps Atomique International (TAI) timescale. Values are represented internally with the TAI64 format defined by Dan Bernstein, and support precision to the nearest second. Functions are provided that: - acquire the current time in TAI64 format. - compare, add and subtract values. - convert between TAI64 values and a portable external format called the "TAI64 label", which is essentially an array of eight octets. - convert between TAI64 values and the float values returned by the [Unix.time] function. Constants are also provided that define the boundaries of valid TAI64 representations. {b Warning:} This implementation obtains the current time of day using the POSIX [time()] function, which returns a value based on the UTC timescale (but with leap seconds "elided" in a way that makes conversions between POSIX time, Standard Time and TAI a perilous undertaking). See the {!Cf_stdtime} module for details. *) (** {6 Types} *) (** Abstract values of TAI64 type *) type t (** {6 Exceptions} *) exception Range_error (** Result not representable in TAI64 format. *) exception Label_error (** Input is not a valid TAI64 label *) (** {6 Functions} *) (** A total ordering function, defined so that the [Cf_tai64] module has the signature of the {!Cf_ordered.Total_T} module type. [compare a b] compares two TAI64 values and returns either [-1], [0], or [1] depending on the relative total ordering of the values. *) val compare: t -> t -> int (** Returns the current time in TAI64, obtained by reading the current time from the POSIX [time()] function, and adjusting for leap seconds. (Currently, the leap seconds table is hardcoded into the library, and the most recent leap second announcement was for Dec 31, 1998.) *) val now: unit -> t (** The earliest TAI epoch representable in the TAI64 format. The TAI64 label is [0000000000000000]. *) val first: t (** The latest TAI epoch representable in the TAI64 format. The TAI64 label is [7fffffffffffffff]. *) val last: t (** Converts a TAI64 value to a value consistent with the result of calling the [Unix.gettimeofday] function. *) val to_unix_time: t -> float (** Converts a value consistent with the result of calling the [Unix.time] function into a TAI64 value. *) val of_unix_time: float -> t (** Returns a string of 8 characters containing the TAI64 label corresponding to the TAI64 value of its argument. *) val to_label: t -> string (** Interprets the argument as a TAI64 label and returns the corresponding TAI64 value. Raises [Label_error] if the label is not a valid TAI64 label. *) val of_label: string -> t (** Add seconds to a TAI64 value. Raises [Range_error] if the result is not a valid TAI64 value. *) val add: t -> int -> t (** Add seconds to a TAI64 value. Raises [Range_error] if the result is not a valid TAI64 value. *) val add_int32: t -> int32 -> t (** Add seconds to a TAI64 value. Raises [Range_error] if the result is not a valid TAI64 value. *) val add_int64: t -> int64 -> t (** Subtract one TAI64 value from another. [sub t0 t1] returns the number of seconds before [t0] that [t1] denotes. *) val sub: t -> t -> int64 (**/**) (** The TAI64 value defining the beginning of the TAI64 epoch, i.e. 00:00:10, 01 Jan 1970 UTC. The TAI64 label is [4000000000000000]. *) val epoch: t (** The TAI epoch marking the start of the Modified Julian Day scale, i.e. 00:00:00, 17 Nov 1858 TAI. The TAI64 label is [3fffffff2efbbf8a]. *) val mjd_epoch: t (** Used by {!Cf_stdtime} for conversions from ISO 8601 timestamps to TAI64. *) val leapsec_add: t -> bool -> t (** Used by {!Cf_stdtime} for conversions from TAI64 to ISO 8601 timestamps. *) val leapsec_sub: t -> bool * t (*--- End of File [ cf_tai64.mli ] ---*) cf-0.10/cf_tai64_p.c0000644000175000017500000002466710674120413014015 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_tai64_p.c Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_tai64_p.h" #include #include #include static int cf_tai64_op_compare(value v1, value v2); static long cf_tai64_op_hash(value v); static void cf_tai64_op_serialize (value v, unsigned long* z32, unsigned long* z64); static unsigned long cf_tai64_op_deserialize(void* buffer); static value* cf_tai64_range_error_exn = 0; static value* cf_tai64_label_error_exn = 0; static value cf_tai64_epoch_val = Val_unit; static value cf_tai64_first_val = Val_unit; static value cf_tai64_last_val = Val_unit; static value cf_tai64_mjd_epoch_val = Val_unit; int cf_tai64_current_offset = 10; void cf_tai64_range_error(void) { CAMLparam0(); CAMLlocal1(exnVal); if (!cf_tai64_range_error_exn) cf_tai64_range_error_exn = caml_named_value("Cf_tai64.Range_error"); if (!cf_tai64_range_error_exn) invalid_argument ("Cf_tai64: Range_error exception unavailable in primitive."); exnVal = alloc_small(1, 0); Store_field(exnVal, 0, *cf_tai64_range_error_exn); mlraise(exnVal); CAMLreturn0; } void cf_tai64_label_error(void) { CAMLparam0(); CAMLlocal1(exnVal); if (!cf_tai64_label_error_exn) cf_tai64_label_error_exn = caml_named_value("Cf_tai64.Label_error"); if (!cf_tai64_label_error_exn) invalid_argument ("Cf_tai64: Label_error exception unavailable in primitive."); exnVal = alloc_small(1, 0); Store_field(exnVal, 0, *cf_tai64_label_error_exn); caml_raise(exnVal); CAMLreturn0; } static struct custom_operations cf_tai64_op = { "org.conjury.ocnae.cf.tai64", custom_finalize_default, cf_tai64_op_compare, cf_tai64_op_hash, cf_tai64_op_serialize, cf_tai64_op_deserialize }; static int cf_tai64_op_compare(value v1, value v2) { CAMLparam2(v1, v2); const Cf_tai64_t* v1Ptr; const Cf_tai64_t* v2Ptr; int result; v1Ptr = Cf_tai64_val(v1); v2Ptr = Cf_tai64_val(v2); if (v2Ptr->s > v1Ptr->s) result = 1; else if (v1Ptr->s > v2Ptr->s) result = -1; else result = 0; CAMLreturn(result); } static long cf_tai64_op_hash(value v) { CAMLparam1(v); CAMLreturn((long) Cf_tai64_val(v)->s); } static void cf_tai64_op_serialize (value v, unsigned long* size32Ptr, unsigned long* size64Ptr) { CAMLparam1(v); char buffer[8]; unsigned long long x; int i; x = Cf_tai64_val(v)->s; for (i = 7; i >= 0; --i) { u_int8_t ch = x & 0xFFULL; x >>= 8; buffer[i] = (char) ch; } serialize_block_1(buffer, 8); *size32Ptr = 8; *size64Ptr = 8; CAMLreturn0; } static unsigned long cf_tai64_op_deserialize(void* data) { char buffer[8]; unsigned long long x; int i; deserialize_block_1(buffer, 8); x = 0ULL; for (i = 7; i >= 0; --i) { u_int8_t ch = (u_int8_t) buffer[i]; x <<= 8; x |= (unsigned long long) ch; } ((Cf_tai64_t*) data)->s = x; return 8; } /*--- Allocate an initialized structure ---*/ extern value cf_tai64_alloc(const Cf_tai64_t* tai64Ptr) { value result; result = alloc_custom(&cf_tai64_op, sizeof *tai64Ptr, 0, 1); *Cf_tai64_val(result) = *tai64Ptr; return result; } /*--- Compare primitive ---*/ CAMLprim value cf_tai64_compare(value v1, value v2) { CAMLparam2(v1, v2); int dt; dt = cf_tai64_op_compare(v1, v2); CAMLreturn(Val_int(dt)); } /*--- Set to current time 1972-01-01 00:00:00 UTC was 1972-01-01 00:00:10 TAI Unix time_t values include all currently defined leap seconds ---*/ extern void cf_tai64_update(Cf_tai64_t* tai64Ptr) { uint64 epoch; epoch = CF_TAI64_EPOCH; epoch += cf_tai64_current_offset; tai64Ptr->s = epoch + ((uint64) time(0)); } /*--- Allocate and set to current time ---*/ CAMLprim value cf_tai64_now(value unit) { CAMLparam0(); CAMLlocal1(result); Cf_tai64_t x; cf_tai64_update(&x); result = cf_tai64_alloc(&x); CAMLreturn(result); } /*--- Allocate global value of TAI64 epoch ---*/ CAMLprim value cf_tai64_epoch(value unit) { CAMLparam0(); CAMLreturn(cf_tai64_epoch_val); } /*--- Allocate global value of the first representable TAI64 ---*/ CAMLprim value cf_tai64_first(value unit) { CAMLparam0(); CAMLreturn(cf_tai64_first_val); } /*--- Allocate global value of the last representable TAI64 ---*/ CAMLprim value cf_tai64_last(value unit) { CAMLparam0(); CAMLreturn(cf_tai64_last_val); } /*--- Allocate global value of the Modified Julian Date (MJD) epoch ---*/ CAMLprim value cf_tai64_mjd_epoch(value unit) { CAMLparam0(); CAMLreturn(cf_tai64_mjd_epoch_val); } /*--- Set the current offset between UTC and TAI ---*/ CAMLprim void cf_tai64_set_current_offset(value v) { CAMLparam1(v); cf_tai64_current_offset = Int_val(v); CAMLreturn0; } /*--- Convert a floating point Unix.time result to TAI ---*/ CAMLprim value cf_tai64_of_unix_time(value v) { CAMLparam1(v); CAMLlocal1(result); static const double cf_tai64_unix_limit[2] = { -((double)CF_TAI64_EPOCH), ((double)(CF_TAI64_EPOCH << 1) - CF_TAI64_EPOCH - 1), }; Cf_tai64_t tai64; double x; x = ceil(Double_val(v)); x += (double) cf_tai64_current_offset; if (x < cf_tai64_unix_limit[0] || x > cf_tai64_unix_limit[1]) cf_tai64_range_error(); tai64.s = CF_TAI64_EPOCH + ((int64) x); result = cf_tai64_alloc(&tai64); CAMLreturn(result); } /*--- Convert a TAI value to a floating point Unix.time result ---*/ CAMLprim value cf_tai64_to_unix_time(value v) { CAMLparam1(v); CAMLlocal1(result); double x; uint64 epoch; epoch = CF_TAI64_EPOCH; epoch += cf_tai64_current_offset; x = (double) (Cf_tai64_val(v)->s - epoch); result = copy_double(x); CAMLreturn(result); } /*--- Convert a string containing a TAI label into the corresponding value ---*/ CAMLprim value cf_tai64_of_label(value v) { CAMLparam1(v); CAMLlocal1(result); Cf_tai64_t tai64; int i; uint64 x; if (string_length(v) != 8) cf_tai64_label_error(); for (i = 0, x = 0; i < 8; ++i) x = (x << 8) | Byte_u(v, i); tai64.s = x; result = cf_tai64_alloc(&tai64); CAMLreturn(result); } /*--- Convert a TAI value to a Caml string containing its label ---*/ CAMLprim value cf_tai64_to_label(value v) { CAMLparam1(v); CAMLlocal1(result); uint64 x; int i; result = alloc_string(8); x = Cf_tai64_val(v)->s; for (i = 7, x = Cf_tai64_val(v)->s; i >= 0; --i, x >>= 8) Byte_u(result, i) = (unsigned char) x; CAMLreturn(result); } /*--- Addition of integer ---*/ CAMLprim value cf_tai64_add_int(value tai64Val, value dtVal) { CAMLparam2(tai64Val, dtVal); CAMLlocal1(result); Cf_tai64_t x; x.s = Cf_tai64_val(tai64Val)->s + Int_val(dtVal); if (x.s >= (CF_TAI64_EPOCH << 1)) cf_tai64_range_error(); result = cf_tai64_alloc(&x); CAMLreturn(result); } /*--- Addition of int32 ---*/ CAMLprim value cf_tai64_add_int32(value tai64Val, value dt32Val) { CAMLparam2(tai64Val, dt32Val); CAMLlocal1(result); Cf_tai64_t x; x.s = Cf_tai64_val(tai64Val)->s + Int32_val(dt32Val); if (x.s >= (CF_TAI64_EPOCH << 1)) cf_tai64_range_error(); result = cf_tai64_alloc(&x); CAMLreturn(result); } /*--- Addition of int64 ---*/ CAMLprim value cf_tai64_add_int64(value tai64Val, value dt64Val) { CAMLparam2(tai64Val, dt64Val); CAMLlocal1(result); Cf_tai64_t x; int64 dt64; dt64 = Int64_val(dt64Val); if (dt64 >= (CF_TAI64_EPOCH << 1)) cf_tai64_range_error(); x.s = Cf_tai64_val(tai64Val)->s + dt64; if (x.s >= (CF_TAI64_EPOCH << 1)) cf_tai64_range_error(); result = cf_tai64_alloc(&x); CAMLreturn(result); } /*--- Subtraction of tai64 values ---*/ CAMLprim value cf_tai64_sub(value v1, value v2) { CAMLparam2(v1, v2); int64 dt; dt = Cf_tai64_val(v1)->s - Cf_tai64_val(v2)->s; CAMLreturn(copy_int64(dt)); } /*--- Initialization primtive ---*/ CAMLprim value cf_tai64_init(value unit) { static const Cf_tai64_t epoch = { CF_TAI64_EPOCH }; static const Cf_tai64_t first = { 0ULL }; static const Cf_tai64_t last = { (CF_TAI64_EPOCH << 1) - 1 }; static const Cf_tai64_t mjd_epoch = { CF_TAI64_MJD_EPOCH }; register_custom_operations(&cf_tai64_op); register_global_root(&cf_tai64_epoch_val); cf_tai64_epoch_val = cf_tai64_alloc(&epoch); register_global_root(&cf_tai64_first_val); cf_tai64_first_val = cf_tai64_alloc(&first); register_global_root(&cf_tai64_last_val); cf_tai64_last_val = cf_tai64_alloc(&last); register_global_root(&cf_tai64_mjd_epoch_val); cf_tai64_mjd_epoch_val = cf_tai64_alloc(&mjd_epoch); return Val_unit; } /*--- End of File [ cf_tai64_p.c ] ---*/ cf-0.10/cf_tai64_p.h0000644000175000017500000000431310404616701014005 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_tai64_p.h Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_TAI64_P_H #define _CF_TAI64_P_H #include "cf_common_p.h" #if !defined(ARCH_INT64_TYPE) #error 64-bit arithmetic not supported by C compiler (fix!) #else #endif #define CF_TAI64_EPOCH 0x4000000000000000ULL #define CF_TAI64_MJD_EPOCH 0x3fffffff2efbbf8aULL struct cf_tai64_s { uint64 s; }; typedef struct cf_tai64_s Cf_tai64_t; #define Cf_tai64_val(v) ((Cf_tai64_t*) Data_custom_val(v)) extern void cf_tai64_range_error(void); extern void cf_tai64_label_error(void); extern value cf_tai64_alloc(const Cf_tai64_t* tai64Ptr); extern void cf_tai64_update(Cf_tai64_t* tai64Ptr); extern int cf_tai64_current_offset; #endif /* defined(_CF_TAI64_P_H) */ /*--- End of File [ cf_tai64_p.h ] ---*/ cf-0.10/cf_tai64n.ml0000644000175000017500000000445410433520573014036 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_tai64n.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) type t external compare: t -> t -> int = "cf_tai64n_compare" external now: unit -> t = "cf_tai64n_now" external first_: unit -> t = "cf_tai64n_first" external last_: unit -> t = "cf_tai64n_last" external compose: Cf_tai64.t -> int -> t = "cf_tai64n_compose" external decompose: t -> Cf_tai64.t * int = "cf_tai64n_decompose" external to_unix_time: t -> float = "cf_tai64n_to_unix_time" external of_unix_time: float -> t = "cf_tai64n_of_unix_time" external to_label: t -> string = "cf_tai64n_to_label" external of_label: string -> t = "cf_tai64n_of_label" external add: t -> float -> t = "cf_tai64n_add" external sub: t -> t -> float = "cf_tai64n_sub" ;; external init_: unit -> unit = "cf_tai64_init";; init_ ();; let first = first_ () let last = last_ () (*--- End of File [ cf_tai64n.ml ] ---*) cf-0.10/cf_tai64n.mli0000644000175000017500000001207310456202024014174 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_tai64n.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** Computations with the Temps Atomique International (TAI) timescale. *) (** {6 Overview} This module (and its cognate {!Cf_tai64}) defines an abstract type and associated functions for computations with values representing epochs in the Temps Atomique International (TAI) timescale. Values are represented internally with the TAI64 format defined by Dan Bernstein, and support precision to the nearest nanosecond. Functions are provided that: - acquire the current time in TAI64N format. - compare, add and subtract values. - convert between TAI64N values and a portable external format called the "TAI64N label", which is essentially an array of twelve octets. - convert between TAI64N values and the float values returned by the [Unix.gettimeofday] function. Constants are also provided that define the boundaries of valid TAI64N representations. {b Warning:} This implementation obtains the current time of day using the POSIX [gettimeofday()] function, which returns a value based on the UTC timescale (but with leap seconds "elided" in a way that makes conversions between POSIX time, Standard Time and TAI a perilous undertaking). See the {!Cf_stdtime} module for details. *) (** {6 Types} *) (** Abstract values of TAI64N type *) type t (** {6 Functions} *) (** A total ordering function, defined so that the [Cf_tai64n] module has the signature of the {!Cf_ordered.Total_T} module type. [compare a b] compares two TAI64N values and returns either [-1], [0], or [1] depending on the relative total ordering of the values. *) val compare: t -> t -> int (** Returns the current time in TAI64N, obtained by reading the current time from the POSIX [gettimeofday()] function, and adjusting for leap seconds. (Currently, the leap seconds table is hardcoded into the library, and the most recent leap second announcement was for Dec 31, 1998.) *) val now: unit -> t (** The earliest TAI epoch representable in the TAI64N format. The TAI64N label is [00000000 00000000 00000000]. *) val first: t (** The latest TAI epoch representable in the TAI64N format. The TAI64N label is [7fffffff ffffffff 3b9ac9ff]. *) val last: t (** Use [compose s ns] to compose a TAI64N value from a TAI64 value [s] and an offset of [ns] nanoseconds. Raises [Invalid_argument] if the number of nanoseconds is greater than 10{^12}. *) val compose: Cf_tai64.t -> int -> t (** Use [decompose x] to separate the TAI64N value [x] into a TAI64 value and an offset in nanoseconds. *) val decompose: t -> Cf_tai64.t * int (** Converts a TAI64 value to a value consistent with the result of calling the [Unix.gettimeofday] function. *) val to_unix_time: t -> float (** Converts a value consistent with the result of calling the [Unix.gettimeofday] function into a TAI64N value. *) val of_unix_time: float -> t (** Returns a string of 8 characters containing the TAI64N label corresponding to the TAI64N value of its argument. *) val to_label: t -> string (** Interprets the argument as a TAI64N label and returns the corresponding TAI64N value. Raises [Cf_tai64.Label_error] if the label is not a valid TAI64N label. *) val of_label: string -> t (** Add seconds to a TAI64N value. Raises [Cf_tai64.Range_error] if the result is not a valid TAI64N value. *) val add: t -> float -> t (** Subtract one TAI64N value from another. [sub t0 t1] returns the number of seconds before [t0] that [t1] denotes. *) val sub: t -> t -> float (*--- End of File [ cf_tai64n.mli ] ---*) cf-0.10/cf_tai64n_p.c0000644000175000017500000002464410404616701014167 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_tai64n_p.c Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #include "cf_tai64n_p.h" #include #include #include #define INVALID_ARGUMENT(S) (invalid_argument("Cf_tai64n." S)) static int cf_tai64n_op_compare(value v1, value v2); static long cf_tai64n_op_hash(value v); static void cf_tai64n_op_serialize (value v, unsigned long* z32, unsigned long* z64); static unsigned long cf_tai64n_op_deserialize(void* buffer); static value cf_tai64n_first_val = Val_unit; static value cf_tai64n_last_val = Val_unit; static struct custom_operations cf_tai64n_op = { "org.conjury.ocnae.cf.tai64n", custom_finalize_default, cf_tai64n_op_compare, cf_tai64n_op_hash, cf_tai64n_op_serialize, cf_tai64n_op_deserialize }; static int cf_tai64n_op_compare(value v1, value v2) { CAMLparam2(v1, v2); const Cf_tai64n_t* v1Ptr; const Cf_tai64n_t* v2Ptr; int result; v1Ptr = Cf_tai64n_val(v1); v2Ptr = Cf_tai64n_val(v2); if (v2Ptr->s > v1Ptr->s) result = 1; else if (v1Ptr->s > v2Ptr->s) result = -1; else if (v2Ptr->ns > v1Ptr->ns) result = 1; else if (v1Ptr->ns > v2Ptr->ns) result = -1; else result = 0; CAMLreturn(result); } static long cf_tai64n_op_hash(value v) { CAMLparam1(v); Cf_tai64n_t* vPtr; vPtr = Cf_tai64n_val(v); CAMLreturn((uint32) vPtr->s ^ vPtr->ns); } static void cf_tai64n_op_serialize (value v, unsigned long* size32Ptr, unsigned long* size64Ptr) { CAMLparam1(v); char buffer[12]; unsigned long long x; uint32 y; int i; x = Cf_tai64n_val(v)->s; for (i = 7; i >= 0; --i) { u_int8_t ch = x & 0xFFULL; x >>= 8; buffer[i] = (char) ch; } y = Cf_tai64n_val(v)->ns; for (i = 11; i >= 8; --i) { u_int8_t ch = y & 0xFFUL; y >>= 8; buffer[i] = (char) ch; } serialize_block_1(buffer, 12); *size32Ptr = 12; *size64Ptr = 12; CAMLreturn0; } static unsigned long cf_tai64n_op_deserialize(void* data) { char buffer[12]; unsigned long long x; uint32 y; int i; deserialize_block_1(buffer, 8); x = 0ULL; for (i = 7; i >= 0; --i) { u_int8_t ch = (u_int8_t) buffer[i]; x <<= 8; x |= (unsigned long long) ch; } y = 0UL; for (i = 11; i >= 8; --i) { u_int8_t ch = (u_int8_t) buffer[i]; y <<= 8; y |= (unsigned long long) ch; } ((Cf_tai64n_t*) data)->s = x; ((Cf_tai64n_t*) data)->ns = y; return 12; } /*--- Compare primitive ---*/ CAMLprim value cf_tai64n_compare(value v1, value v2) { CAMLparam2(v1, v2); int dt; dt = cf_tai64n_op_compare(v1, v2); CAMLreturn(Val_int(dt)); } /*--- Allocate an initialized structure ---*/ extern value cf_tai64n_alloc(const Cf_tai64n_t* tai64nPtr) { value result; result = alloc_custom(&cf_tai64n_op, sizeof *tai64nPtr, 0, 1); *Cf_tai64n_val(result) = *tai64nPtr; return result; } /*--- Set to current time 1972-01-01 00:00:00 UTC was 1972-01-01 00:00:10 TAI Unix time values include all currently defined leap seconds ---*/ extern void cf_tai64n_update(Cf_tai64n_t* tai64nPtr) { uint64 epoch; struct timeval tv; struct timezone tz; if (gettimeofday(&tv, &tz)) unix_error(errno, "gettimeofday", Nothing); epoch = CF_TAI64_EPOCH; epoch += cf_tai64_current_offset; tai64nPtr->s = epoch + ((uint64) tv.tv_sec); tai64nPtr->ns = tv.tv_usec * 1000; } /*--- Allocate and set to current time ---*/ CAMLprim value cf_tai64n_now(value unit) { CAMLparam0(); CAMLlocal1(result); Cf_tai64n_t x; cf_tai64n_update(&x); result = cf_tai64n_alloc(&x); CAMLreturn(result); } /*--- Allocate global value of the first representable TAI64N ---*/ CAMLprim value cf_tai64n_first(value unit) { CAMLparam0(); CAMLreturn(cf_tai64n_first_val); } /*--- Allocate global value of the last representable TAI64N ---*/ CAMLprim value cf_tai64n_last(value unit) { CAMLparam0(); CAMLreturn(cf_tai64n_last_val); } /*--- external compose: Cf_tai64.t -> int -> t = "cf_tai64n_compose" ---*/ CAMLprim value cf_tai64n_compose(value tai64Val, value nsVal) { CAMLparam2(tai64Val, nsVal); CAMLlocal1(resultVal); Cf_tai64_t* tai64Ptr; uint32 ns; Cf_tai64n_t tai64n; tai64Ptr = Cf_tai64_val(tai64Val); ns = (uint32) Int_val(nsVal); if (ns < 0 || ns > 999999999) INVALID_ARGUMENT("compose: ns > 10^9"); tai64n.s = tai64Ptr->s; tai64n.ns = ns; resultVal = cf_tai64n_alloc(&tai64n); CAMLreturn(resultVal); } /*--- external decompose: t -> Cf_tai64.t * int = "cf_tai64n_decompose" ---*/ CAMLprim value cf_tai64n_decompose(value tai64nVal) { CAMLparam1(tai64nVal); CAMLlocal2(resultVal, tai64Val); Cf_tai64_t tai64; tai64.s = Cf_tai64n_val(tai64nVal)->s; tai64Val = cf_tai64_alloc(&tai64); resultVal = alloc_small(2, 0); Store_field(resultVal, 0, tai64Val); Store_field(resultVal, 1, Val_int(Cf_tai64n_val(tai64nVal)->ns)); CAMLreturn(resultVal); } /*--- Convert a floating point Unix.time result to TAI ---*/ CAMLprim value cf_tai64n_of_unix_time(value v) { CAMLparam1(v); CAMLlocal1(result); static const double cf_tai64_unix_limit[2] = { -((double)CF_TAI64_EPOCH), ((double)(CF_TAI64_EPOCH << 1) - CF_TAI64_EPOCH - 1), }; Cf_tai64n_t tai64n; double x, y; y = (uint64) modf(Double_val(v), &x); x += (double) cf_tai64_current_offset; if (x < cf_tai64_unix_limit[0] || x > cf_tai64_unix_limit[1]) cf_tai64_range_error(); tai64n.s = CF_TAI64_EPOCH + ((uint64) x); tai64n.ns = (uint32) (y * 1E9); result = cf_tai64n_alloc(&tai64n); CAMLreturn(result); } /*--- Convert a TAI value to a floating point Unix.time result ---*/ CAMLprim value cf_tai64n_to_unix_time(value v) { CAMLparam1(v); CAMLlocal1(result); double x, y; uint64 epoch; epoch = CF_TAI64_EPOCH; epoch += cf_tai64_current_offset; x = (double) (Cf_tai64n_val(v)->s - epoch); y = ((double) Cf_tai64n_val(v)->ns) * 1E-9; result = copy_double(x + y); CAMLreturn(result); } /*--- Convert a string containing a TAI64N label into the corresponding value ---*/ CAMLprim value cf_tai64n_of_label(value v) { CAMLparam1(v); CAMLlocal1(result); Cf_tai64n_t tai64n; int i; uint64 x; uint32 y; if (string_length(v) != 12) cf_tai64_label_error(); for (i = 0, x = 0; i < 8; ++i) x = (x << 8) | Byte_u(v, i); for (i = 8, y = 0; i < 12; ++i) y = (y << 8) | Byte_u(v, i); tai64n.s = x; tai64n.ns = y; result = cf_tai64n_alloc(&tai64n); CAMLreturn(result); } /*--- Convert a TAI64N value to a Caml string containing its label ---*/ CAMLprim value cf_tai64n_to_label(value v) { CAMLparam1(v); CAMLlocal1(result); uint64 x; uint32 y; int i; result = alloc_string(12); x = Cf_tai64n_val(v)->s; for (i = 7; i >= 0; --i, x >>= 8) Byte_u(result, i) = (unsigned char) x; y = Cf_tai64n_val(v)->ns; for (i = 11; i >= 8; --i, y >>= 8) Byte_u(result, i) = (unsigned char) y; CAMLreturn(result); } /*--- Addition of float ---*/ CAMLprim value cf_tai64n_add(value tai64nVal, value dtVal) { CAMLparam2(tai64nVal, dtVal); CAMLlocal1(result); Cf_tai64n_t tai64n; double zInt, zFrac; int64 x; int32 y; zFrac = modf(Double_val(dtVal), &zInt); x = (int64) zInt; y = (int32) (zFrac * 1E9); tai64n.s = Cf_tai64n_val(tai64nVal)->s + x; tai64n.ns = Cf_tai64n_val(tai64nVal)->ns + y; if (tai64n.ns < 0) { tai64n.ns += 1000000000; tai64n.s -= 1; } else if (tai64n.ns >= 1000000000) { tai64n.ns -= 1000000000; tai64n.s += 1; } if (tai64n.s >= (CF_TAI64_EPOCH << 1)) cf_tai64_range_error(); result = cf_tai64n_alloc(&tai64n); CAMLreturn(result); } /*--- Subtraction of TAI64N values ---*/ CAMLprim value cf_tai64n_sub(value v1, value v2) { CAMLparam2(v1, v2); CAMLlocal1(resultVal); double dt; dt = ((int64) Cf_tai64n_val(v1)->s) - ((int64) Cf_tai64n_val(v2)->s); dt += (((int32) Cf_tai64n_val(v1)->ns) - ((int32) Cf_tai64n_val(v2)->ns)) * 1E-9; resultVal = copy_double(dt); CAMLreturn(resultVal); } /*--- Initialization primtive ---*/ CAMLprim value cf_tai64n_init(value unit) { static const Cf_tai64n_t first = { 0ULL, 0UL }; static const Cf_tai64n_t last = { (CF_TAI64_EPOCH << 1) - 1, 999999999UL }; register_custom_operations(&cf_tai64n_op); register_global_root(&cf_tai64n_first_val); cf_tai64n_first_val = cf_tai64n_alloc(&first); register_global_root(&cf_tai64n_last_val); cf_tai64n_last_val = cf_tai64n_alloc(&last); return Val_unit; } /*--- End of File [ cf_tai64n_p.c ] ---*/ cf-0.10/cf_tai64n_p.h0000644000175000017500000000364710404616701014174 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_tai64n_p.h Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*/ #ifndef _CF_TAI64N_P_H #define _CF_TAI64N_P_H #include "cf_tai64_p.h" struct cf_tai64n_s { uint64 s; uint32 ns; }; typedef struct cf_tai64n_s Cf_tai64n_t; #define Cf_tai64n_val(v) ((Cf_tai64n_t*) Data_custom_val(v)) extern value cf_tai64n_alloc(const Cf_tai64n_t* tai64nPtr); extern void cf_tai64n_update(Cf_tai64n_t* tai64nPtr); #endif /* defined(_CF_TAI64N_P_H) */ /*--- End of File [ cf_tai64n_p.h ] ---*/ cf-0.10/cf_tcp4_socket.ml0000644000175000017500000000316210433520573015146 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_tcp4_socket.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) include Cf_sock_stream.Create(Cf_ip4_proto.TCP);; (*--- End of File [ cf_tcp4_socket.ml ] ---*) cf-0.10/cf_tcp4_socket.mli0000644000175000017500000000323010433520573015313 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_tcp4_socket.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** TCP sockets (over IPv4). *) include Cf_sock_stream.T with module P = Cf_ip4_proto.TCP (*--- End of File [ cf_tcp4_socket.mli ] ---*) cf-0.10/cf_tcp6_socket.ml0000644000175000017500000000316210433520573015150 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_tcp6_socket.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) include Cf_sock_stream.Create(Cf_ip6_proto.TCP);; (*--- End of File [ cf_tcp6_socket.ml ] ---*) cf-0.10/cf_tcp6_socket.mli0000644000175000017500000000323010433520573015315 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_tcp6_socket.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** TCP sockets (over IPv6). *) include Cf_sock_stream.T with module P = Cf_ip6_proto.TCP (*--- End of File [ cf_tcp6_socket.mli ] ---*) cf-0.10/cf_udp4_socket.ml0000644000175000017500000000316110433520573015147 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_udp4_socket.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) include Cf_sock_dgram.Create(Cf_ip4_proto.UDP);; (*--- End of File [ cf_udp4_socket.ml ] ---*) cf-0.10/cf_udp4_socket.mli0000644000175000017500000000322710433520573015323 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_udp4_socket.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** UDP sockets (over IPv4). *) include Cf_sock_dgram.T with module P = Cf_ip4_proto.UDP (*--- End of File [ cf_udp4_socket.mli ] ---*) cf-0.10/cf_udp6_socket.ml0000644000175000017500000000316110433520573015151 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_udp6_socket.ml Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) include Cf_sock_dgram.Create(Cf_ip6_proto.UDP);; (*--- End of File [ cf_udp6_socket.ml ] ---*) cf-0.10/cf_udp6_socket.mli0000644000175000017500000000322710433520573015325 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_udp6_socket.mli Copyright (c) 2004-2006, 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. *---------------------------------------------------------------------------*) (** UDP sockets (over IPv6). *) include Cf_sock_dgram.T with module P = Cf_ip6_proto.UDP (*--- End of File [ cf_udp6_socket.mli ] ---*) cf-0.10/cf_unicode.ml0000644000175000017500000002773510433520573014366 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_unicode.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) module type Endian_T = sig val to_ucs2: char -> char -> int val of_ucs2: int -> char * char end module Endian_be: Endian_T = struct let to_ucs2 c0 c1 = let c0 = int_of_char c0 and c1 = int_of_char c1 in (c0 lsr 8) lor c1 let of_ucs2 n = let c1 = char_of_int (n land 0xFF) in let n = n lsr 8 in let c0 = char_of_int (n land 0xFF) in c0, c1 end module Endian_le: Endian_T = struct let to_ucs2 c0 c1 = let c0 = int_of_char c0 and c1 = int_of_char c1 in (c1 lsr 8) lor c0 let of_ucs2 n = let c0 = char_of_int (n land 0xFF) in let n = n lsr 8 in let c1 = char_of_int (n land 0xFF) in c0, c1 end module type Encoding_T = sig val to_ucs4: (char Cf_seq.t option, int) Cf_flow.t val of_ucs4: (int, char) Cf_flow.t end module E_utf8: Encoding_T = struct let to_ucs4 = let rec state0 sopt = match sopt with | None -> Cf_flow.Z | Some seq -> match Lazy.force seq with | Cf_seq.Z -> Cf_flow.Q state0 | Cf_seq.P (hd, tl) -> let c = int_of_char hd in let tl = Some tl in if c < 0b11000000 || c >= 0b11111110 then let hd = if c < 0b10000000 then c else 0xFFFD in Cf_flow.P (hd, lazy (state0 tl)) else let k, x = if c < 0b11100000 then 0, (c land 0b11111) else if c < 0b11110000 then 1, (c land 0b1111) else if c < 0b11111000 then 2, (c land 0b111) else if c < 0b11111100 then 3, (c land 0b11) else 4, (c land 0b1) in state1 ~k ~x tl and state1 ~k ~x sopt = match sopt with | None -> Cf_flow.P (0xFFFD, Lazy.lazy_from_val Cf_flow.Z) | Some seq as p -> match Lazy.force seq with | Cf_seq.Z -> Cf_flow.Q (state1 ~k ~x) | Cf_seq.P (hd, tl) -> let c = int_of_char hd in if c < 0b10000000 then Cf_flow.P (0xFFFD, lazy (state0 p)) else let z = Some tl in let zz = lazy (state0 z) in if c > 0b10111111 then Cf_flow.P (0xFFFD, zz) else let x = (x lsl 6) lor (c land 0b111111) in if k > 0 then let k = pred k in state1 ~k ~x z else Cf_flow.P (x, zz) in Lazy.lazy_from_val (Cf_flow.Q state0) let rec of_ucs4 = lazy begin let rec state0 x = match x with | x when x = x land 0x7f -> state1 0 0 x of_ucs4 | x when x = x land 0x7ff -> state1 0b11000000 1 x of_ucs4 | x when x = x land 0xffff -> state1 0b11100000 2 x of_ucs4 | x when x = x land 0xfffff -> state1 0b11110000 3 x of_ucs4 | x when x = x land 0x3ffffff -> state1 0b11111000 4 x of_ucs4 | x -> state1 0b11111100 5 x of_ucs4 (* UCS4 are 31-bit *) and state1 pre n x w = if n > 0 then begin let c = char_of_int ((x land 0x3f) lor 0x80) in let w = Lazy.lazy_from_val (Cf_flow.P (c, w)) in state1 pre (pred n) (x lsr 6) w end else begin let c = char_of_int (x lor pre) in Cf_flow.P (c, w) end in Cf_flow.Q state0 end end module E_utf16x_create(N: Endian_T): Encoding_T = struct open Cf_flow.Op let utf16_to_ucs2_ = let rec state0 = function | None -> Cf_flow.Z | Some seq -> match Lazy.force seq with | Cf_seq.Z -> Cf_flow.Q state0 | Cf_seq.P (hd, tl) -> state1 ~c0:hd (Some tl) and state1 ~c0 = function | None -> Cf_flow.P (0xFFFD, Lazy.lazy_from_val Cf_flow.Z) | Some seq -> match Lazy.force seq with | Cf_seq.Z -> Cf_flow.Q (state1 ~c0) | Cf_seq.P (hd, tl) -> Cf_flow.P (N.to_ucs2 c0 hd, lazy (state0 (Some tl))) in Lazy.lazy_from_val (Cf_flow.Q state0) let rec ucs2_to_ucs4_ = lazy begin let rec state0 u0 = if u0 >= 0xd800 && u0 < 0xdc00 then Cf_flow.Q (state1 ~u0) else let u0 = if u0 < 0xe000 then 0xfffd else u0 in Cf_flow.P (u0, ucs2_to_ucs4_) and state1 ~u0 u1 = let u = if u1 < 0xdc00 || u1 >= 0xe000 then 0xfffd else ((u0 land 0x3ff) lsl 10) lor (u1 land 0x3ff) in Cf_flow.P (u, ucs2_to_ucs4_) in Cf_flow.Q state0 end let to_ucs4 = utf16_to_ucs2_ -=- ucs2_to_ucs4_ let rec of_ucs4 = lazy begin let put x w = let c0, c1 = N.of_ucs2 x in Cf_flow.P (c0, Lazy.lazy_from_val (Cf_flow.P (c1, w))) in let rec loop x = match x with | x when x = (x land 0xffff) -> put x of_ucs4 | x when x > 0 && x < 0x110000 -> let x = x - 0x10000 in let d800 = 0xd800 lor ((x lsr 10) land 0x3ff) and dc00 = 0xdc00 lor (x land 0x3ff) in put dc00 (Lazy.lazy_from_val (put d800 of_ucs4)) | _ -> put 0xFFFD of_ucs4 in Cf_flow.Q loop end end module E_utf16be: Encoding_T = E_utf16x_create(Endian_be) module E_utf16le: Encoding_T = E_utf16x_create(Endian_le) let any_utf_to_ucs4 = let to_ucs4_f_ x = match Lazy.force E_utf8.to_ucs4 with | Cf_flow.Q f -> f x | _ -> assert false in let rec state1 = function | None -> Cf_flow.Z | Some seq as p-> match Lazy.force seq with | Cf_seq.Z -> Cf_flow.Q state1 | Cf_seq.P (hd, tl) -> let c = int_of_char hd in if c < 0b11111110 then to_ucs4_f_ p else state2 ~c0:hd (Some tl) and state2 ~c0 = function | None -> Cf_flow.P (0xFFFD, Lazy.lazy_from_val Cf_flow.Z) | Some seq -> match Lazy.force seq with | Cf_seq.Z -> Cf_flow.Q (state2 ~c0) | Cf_seq.P (hd, tl) -> let c = int_of_char hd in let w = Cf_flow.P (0xFFFD, lazy (to_ucs4_f_ (Some tl))) in if c < 0b11111110 then w else let u0 = int_of_char c0 and u1 = int_of_char hd in match u0, u1 with | 0xFE, 0xFF -> Lazy.force E_utf16be.to_ucs4 | 0xFF, 0xFE -> Lazy.force E_utf16le.to_ucs4 | _, _ -> w in Lazy.lazy_from_val (Cf_flow.Q state1) module B_utf16_create(N: Endian_T) = struct let prepend_bom w = let c0, c1 = N.of_ucs2 0xFFEF in lazy (Cf_flow.P (c0, lazy (Cf_flow.P (c1, w)))) end module B_utf16be = B_utf16_create(Endian_be) module B_utf16le = B_utf16_create(Endian_le) let ucs4_to_utf16 = function | `BE -> B_utf16be.prepend_bom E_utf16be.of_ucs4 | `LE -> B_utf16le.prepend_bom E_utf16le.of_ucs4 module type Transcoding_T = sig module E: Encoding_T val transcoder: (char Cf_seq.t option, char) Cf_flow.t val transcode: char Cf_seq.t -> char Cf_seq.t val atomic: string -> string end module C_create(E: Encoding_T): Transcoding_T = struct open Cf_flow.Op module E = E let transcoder = E.to_ucs4 -=- E.of_ucs4 let transcode s = Cf_flow.transcode transcoder s let atomic s = Cf_seq.to_string (transcode (Cf_seq.of_string s)) end module E_utf8_to_utf16be: Encoding_T = struct let to_ucs4 = E_utf8.to_ucs4 let of_ucs4 = ucs4_to_utf16 `BE end module E_utf8_to_utf16le: Encoding_T = struct let to_ucs4 = E_utf8.to_ucs4 let of_ucs4 = ucs4_to_utf16 `LE end module E_utf8_to_utf16be_raw: Encoding_T = struct let to_ucs4 = E_utf8.to_ucs4 let of_ucs4 = E_utf16be.of_ucs4 end module E_utf8_to_utf16le_raw: Encoding_T = struct let to_ucs4 = E_utf8.to_ucs4 let of_ucs4 = E_utf16le.of_ucs4 end module E_utf16be_to_utf8: Encoding_T = struct let to_ucs4 = E_utf16be.to_ucs4 let of_ucs4 = E_utf8.of_ucs4 end module E_utf16le_to_utf8: Encoding_T = struct let to_ucs4 = E_utf16le.to_ucs4 let of_ucs4 = E_utf8.of_ucs4 end module E_any_utf_to_utf8: Encoding_T = struct let to_ucs4 = any_utf_to_ucs4 let of_ucs4 = E_utf8.of_ucs4 end module E_any_utf_to_utf16be: Encoding_T = struct let to_ucs4 = any_utf_to_ucs4 let of_ucs4 = ucs4_to_utf16 `BE end module E_any_utf_to_utf16le: Encoding_T = struct let to_ucs4 = any_utf_to_ucs4 let of_ucs4 = ucs4_to_utf16 `LE end module E_any_utf_to_utf16be_raw: Encoding_T = struct let to_ucs4 = any_utf_to_ucs4 let of_ucs4 = E_utf16be.of_ucs4 end module E_any_utf_to_utf16le_raw: Encoding_T = struct let to_ucs4 = any_utf_to_ucs4 let of_ucs4 = E_utf16le.of_ucs4 end module C_utf8_to_utf16be = C_create(E_utf8_to_utf16be) module C_utf8_to_utf16le = C_create(E_utf8_to_utf16le) module C_utf8_to_utf16be_raw = C_create(E_utf8_to_utf16be_raw) module C_utf8_to_utf16le_raw = C_create(E_utf8_to_utf16le_raw) module C_utf16be_to_utf8 = C_create(E_utf16be_to_utf8) module C_utf16le_to_utf8 = C_create(E_utf16le_to_utf8) module C_any_utf_to_utf8 = C_create(E_any_utf_to_utf8) module C_any_utf_to_utf16be = C_create(E_any_utf_to_utf16be) module C_any_utf_to_utf16le = C_create(E_any_utf_to_utf16le) module C_any_utf_to_utf16be_raw = C_create(E_any_utf_to_utf16be_raw) module C_any_utf_to_utf16le_raw = C_create(E_any_utf_to_utf16le_raw) (*--- End of File [ cf_unicode.ml ] ---*) cf-0.10/cf_unicode.mli0000644000175000017500000001314410433520573014524 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_unicode.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** Unicode transcodings. *) (** This module contains a collection of utilities for transcoding streams of Unicode characters between various encoding formats, i.e. UTF8, UTF16 and UCS4. *) (** The module type defining the relationship between UCS4 and a given UTF encoding of Unicode characters. *) module type Encoding_T = sig (** A flow that transcodes an encoded character stream into a stream of 31-bit UCS4 integer codes. *) val to_ucs4: (char Cf_seq.t option, int) Cf_flow.t (** A flow that reads a stream of 31-bit UCS4 integer codes and writes them as a stream of encoded characters. *) val of_ucs4: (int, char) Cf_flow.t end (** The UTF8 encoding *) module E_utf8: Encoding_T (** The UTF16 encoding (big-endian) *) module E_utf16be: Encoding_T (** The UTF16 encoding (little-endian) *) module E_utf16le: Encoding_T (** A flow that transcodes any Unicode encoded character stream into a stream of 31-bit UCS4 integer codes. Determines the encoding format by reading the barker code from the beginning of the input stream. *) val any_utf_to_ucs4: (char Cf_seq.t option, int) Cf_flow.t (** Use [ucs4_to_utf16 endian] to compose a flow that reads a stream of 31-bit UCS4 integer codes and writes a stream comprised of the barker code followed by a stream of UTF16 characters in the 'endian' mode specified. *) val ucs4_to_utf16: [< `BE | `LE ] -> (int, char) Cf_flow.t (** The module type that results from the application of the [C_create(E: Encoding_T)] functor below. Modules of this type represent a transcoding from one Unicode encoding to another Unicode encoding. *) module type Transcoding_T = sig (** The encoding module used as the argument to the [C_create(E: Encoding_T)] functor. The [to_ucs4] function defines the input encoding of the transcoder, and the [of_ucs4] function defines the output encoding. *) module E: Encoding_T (** A transcoder flow. Use [transcoder] with the functions defined in the {!Cf_flow.Transcode} module to transcode between Unicode encodings in in stages. *) val transcoder: (char Cf_seq.t option, char) Cf_flow.t (** Use [transcode i] to convert a sequence of characters in the input encoding into a sequence of characters in the output encoding. *) val transcode: char Cf_seq.t -> char Cf_seq.t (** Use [atomic str] to convert a string in the input encoding into a string in the output encoding. *) val atomic: string -> string end (** The functor used to compose the transcoding modules defined below. *) module C_create(E: Encoding_T): Transcoding_T with module E = E (** Functions for transcoding UTF8 into UTF16 (big-endian) *) module C_utf8_to_utf16be: Transcoding_T (** Functions for transcoding UTF8 into UTF16 (little-endian) *) module C_utf8_to_utf16le: Transcoding_T (** Functions for transcoding UTF8 into UTF16 (big-endian, no barker code) *) module C_utf8_to_utf16be_raw: Transcoding_T (** Functions for transcoding UTF8 into UTF16 (little-endian, no barker code) *) module C_utf8_to_utf16le_raw: Transcoding_T (** Functions for transcoding UTF16 (big-endian, no barker code) into UTF8. *) module C_utf16be_to_utf8: Transcoding_T (** Functions for transcoding UTF16 (little-endian, no barker code) into UTF8. *) module C_utf16le_to_utf8: Transcoding_T (** Functions for transcoding any Unicode character stream into UTF8. *) module C_any_utf_to_utf8: Transcoding_T (** Functions for transcoding any Unicode character stream into UTF16 (big-endian). *) module C_any_utf_to_utf16be: Transcoding_T (** Functions for transcoding any Unicode character stream into UTF16 (little-endian). *) module C_any_utf_to_utf16le: Transcoding_T (** Functions for transcoding any Unicode character stream into UTF16 (big-endian, no barker code). *) module C_any_utf_to_utf16be_raw: Transcoding_T (** Functions for transcoding any Unicode character stream into UTF16 (little-endian, no barker code). *) module C_any_utf_to_utf16le_raw: Transcoding_T (*--- End of File [ cf_unicode.mli ] ---*) cf-0.10/cf_uri.ml0000644000175000017500000004767210433520573013541 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_uri.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) open Cf_flow.Op open Cf_parser.Op open Cf_lex.Op let ch_is_up_alpha_ = function 'A'..'Z' -> true | _ -> false let ch_is_dn_alpha_ = function 'a'..'z' -> true | _ -> false let ch_is_digit_ = function '0'..'9' -> true | _ -> false let ch_is_hex_ = function ('0'..'9' | 'A'..'F' | 'a'..'f') -> true | _ -> false let ch_is_reserved_ = function | (';' | '/' | '?' | ':' | '@' | '&' | '=' | '+' | '$' | ',') -> true | _ -> false let ch_is_reserved_no_slash_ = function | '/' -> false | c -> ch_is_reserved_ c let ch_is_reserved_in_rel_segment_ = function | ('/' | '?' | ':') -> false | c -> ch_is_reserved_ c let ch_is_reserved_in_rel_segment_no_semi_ = function | ';' -> false | c -> ch_is_reserved_in_rel_segment_ c let ch_is_reserved_in_pchar_ = function | ('/' | '?' | ';') -> false | c -> ch_is_reserved_ c let ch_is_reserved_in_userinfo_ = function | ('/' | '?') -> false | c -> ch_is_reserved_ c let ch_is_mark_ = function | ('-' | '_' | '.' | '!' | '~' | '*' | '\'' | '(' | ')') -> true | _ -> false let ch_is_unreserved_ = function | 'A'..'Z' | 'a'..'z' | '0'..'9' -> true | ch -> ch_is_mark_ ch let x_up_alpha_ = !^ch_is_up_alpha_ let x_dn_alpha_ = !^ch_is_dn_alpha_ let x_digit_ = !^ch_is_digit_ let x_hex_ = !^ch_is_hex_ let x_alpha_ = x_up_alpha_ $| x_dn_alpha_ let x_alphanum_ = x_alpha_ $| x_digit_ let x_plus_ = !:'+' let x_hyphen_ = !:'-' let x_dot_ = !:'.' let x_percent_ = !:'%' let x_escaped_ = x_percent_ $& x_hex_ $& x_hex_ let x_unreserved_ = x_alphanum_ $| !^ch_is_mark_ let x_reserved_ = !^ch_is_reserved_ let x_uric_ = x_reserved_ $| x_unreserved_ $| x_escaped_ let x_uric_no_slash_ = !^ch_is_reserved_no_slash_ $| x_unreserved_ $| x_escaped_ let x_pchar_ = !^ch_is_reserved_in_pchar_ $| x_unreserved_ $| x_escaped_ (* let x_semicolon_ = !:';' let x_query_ = !:'?' let x_colon_ = !:':' let x_at_ = !:'@' let x_ampersand_ = !:'&' let x_equal_ = !:'=' let x_dollar_ = !:'$' let x_comma_ = !:',' let x_bang_ = !:'!' let x_tilde_ = !:'~' let x_star_ = !:'*' let x_tick_ = !:'\'' let x_underscore_ = !:'_' let x_lparen_ = !:'(' let x_rparen_ = !:')' *) let int_of_A_ = (int_of_char 'A') - 10 let int_of_a_ = (int_of_char 'a') - 10 let int_of_0_ = int_of_char '0' let int_of_hex_char_ c = let n0 = match c with | 'A'..'F' -> int_of_A_ | 'a'..'f' -> int_of_a_ | '0'..'9' -> int_of_0_ | _ -> assert (not true); 0 in (int_of_char c) - n0 let hex_char_of_int_ n = assert (n >= 0 && n < 16); char_of_int (n + (if n > 9 then int_of_a_ else int_of_0_)) let rec w_escape_ = let rec loop f c = let self = w_escape_ f in if (ch_is_unreserved_ c) or (f c) then Cf_flow.P (c, self) else begin let n = int_of_char c in let c1 = hex_char_of_int_ (n land 0xF) in let z1 = Lazy.lazy_from_val (Cf_flow.P (c1, self)) in let c0 = hex_char_of_int_ ((n land 0xF0) lsr 4) in let z0 = Lazy.lazy_from_val (Cf_flow.P (c0, z1)) in Cf_flow.P ('%', z0) end in fun f -> Lazy.lazy_from_val (Cf_flow.Q (loop f)) let rec w_unescape_ = let rec loop c = let self = w_unescape_ () in match c with | '%' -> Cf_flow.Q begin fun c -> let n0 = int_of_hex_char_ c in Cf_flow.Q begin fun c -> let n1 = int_of_hex_char_ c in Cf_flow.P (char_of_int (n0 * 16 + n1), self) end end | x -> Cf_flow.P (x, self) in fun () -> Lazy.lazy_from_val (Cf_flow.Q loop) let escape ?(allow = (fun _ -> false)) = let w = w_escape_ allow in fun s -> Cf_seq.to_string (Cf_flow.commute w (Cf_seq.of_string s)) let unescape s = Cf_seq.to_string (Cf_flow.commute (w_unescape_ ()) (Cf_seq.of_string s)) let p_colon_ s = ?.':' s let p_semicolon_ s = ?.';' s let p_slash_ s = ?.'/' s let p_dot_ s = ?.'.' s let p_at_ s = ?.'@' s let p_slashslash_ s = let m = ?.'/' >>= fun _ -> ?.'/' >>= fun _ -> ~:() in m s let p_scheme_ = Cf_lex.create begin x_alpha_ $& !*(x_alpha_ $| x_digit_ $| x_plus_ $| x_hyphen_ $| x_dot_) $> String.lowercase end let p_opaque_part_ = Cf_lex.create (x_uric_ $& !*x_uric_no_slash_ $> unescape) let p_uric_string_ = Cf_lex.create (!*x_uric_ $> (fun x -> (x : string))) let p_hostname_ = let x_label_suffix_ = !*(x_alphanum_ $| x_hyphen_) $& x_alphanum_ in let x_toplabel_ = x_alpha_ $| (x_alpha_ $& x_label_suffix_) in let x_domainlabel_ = x_alphanum_ $| (x_alphanum_ $& x_label_suffix_) in let x_hostname_ = !*(x_domainlabel_ $& x_dot_) $& x_toplabel_ $& !?x_dot_ in Cf_lex.create (x_hostname_ $> String.lowercase) let p_ipv4_addr_ = let x_num = !+ !^ch_is_digit_ in let x_ip4_addr = x_num $& x_num $& x_num $& x_num in let action lim s = let s1 = Cf_seq.limit lim s in match Cf_ip4_addr.pton (Cf_seq.to_string s1) with | Some addr -> Some (addr, Cf_seq.shift lim s) | None -> None in Cf_lex.create (x_ip4_addr $@ action) type host = | H_hostname of string | H_ip4_addr of Cf_ip4_addr.opaque Cf_ip4_addr.t let p_userinfo_ = Cf_lex.create begin x_unreserved_ $| x_escaped_ $| !^ch_is_reserved_in_userinfo_ $> unescape end type server = { srv_user: string option; srv_host: host; srv_port: int option; } type authority = | A_server of server option | A_reg_name of string let p_port_ = Cf_lex.create ((!* !^ch_is_digit_) $> int_of_string) let p_server_ = let p_userinfo_at_ = p_userinfo_ >>= fun ui -> p_at_ >>= fun _ -> ~:ui in let p_userinfo_opt_ = ?/ p_userinfo_at_ in let p_host_ = Cf_parser.alt [ (p_ipv4_addr_ >>= fun addr -> ~:(H_ip4_addr addr)); (p_hostname_ >>= fun name -> ~:(H_hostname name)); ] in let p_port_opt_ = ?/ (p_colon_ >>= fun _ -> p_port_) in ?/ begin p_userinfo_opt_ >>= fun user -> p_host_ >>= fun host -> p_port_opt_ >>= fun port -> ~:{ srv_user = user; srv_host = host; srv_port = port; } end let p_reg_name_ = Cf_lex.create begin !+(x_unreserved_ $| x_escaped_ $| !^ch_is_reserved_in_userinfo_) $> unescape end let p_authority_ = Cf_parser.alt [ (p_server_ >>= fun srv -> ~:(A_server srv)); (p_reg_name_ >>= fun rn -> ~:(A_reg_name rn)); ] let p_pchar_star_ = Cf_lex.create (!* x_pchar_ $> unescape) let p_param_ = p_semicolon_ >>= fun _ -> p_pchar_star_ type segment = { seg_name: string; seg_params: string list; } let p_segment_ = p_pchar_star_ >>= fun name -> ?*p_param_ >>= fun params -> ~:{ seg_name = name; seg_params = params } let p_path_segments_ = let p_list_ = p_slash_ >>= fun _ -> p_segment_ in p_segment_ >>= fun hd -> ?*p_list_ >>= fun tl -> ~:(hd, tl) let p_abs_path_ = p_slash_ >>= fun _ -> p_path_segments_ let p_rel_segment_no_semi_ = Cf_lex.create begin let reserved = !^ch_is_reserved_in_rel_segment_no_semi_ in !+ (x_unreserved_ $| x_escaped_ $| reserved) $> unescape; end let p_rel_segment_nonempty_ = p_rel_segment_no_semi_ >>= fun name -> ?*p_param_ >>= fun params -> ~:{ seg_name = name; seg_params = params } let p_rel_segment_empty_with_params_ = ?+p_param_ >>= fun (param_hd, param_tl) -> ~:{ seg_name = ""; seg_params = param_hd :: param_tl } let p_rel_segment_ = Cf_parser.alt [ p_rel_segment_nonempty_; p_rel_segment_empty_with_params_; ] let p_rel_path_ = p_rel_segment_ >>= fun rseg -> ?/ p_abs_path_ >>= fun absopt -> ~:begin match rseg, absopt with | { seg_name = ""; seg_params = [] }, Some (hd, tl) -> hd :: tl | hd, None -> hd :: [] | hd, Some (tl1, tlx) -> hd :: tl1 :: tlx end type net_path = { net_authority: authority; net_path: segment list; } let p_net_path_ = p_slashslash_ >>= fun _ -> p_authority_ >>= fun a -> ?/ p_abs_path_ >>= fun p_opt -> let p = match p_opt with None -> [] | Some (hd, tl) -> hd :: tl in ~:{ net_authority = a; net_path = p } type net = [ `Net of net_path ] type abs = [ `Abs of segment * segment list ] type rel = [ `Rel of segment list ] type path = [ net | abs | rel ] let p_query_ = ?/ (?.'?' >>= fun _ -> p_uric_string_) let p_fragment_ = ?/ begin ?.'#' >>= fun _ -> p_uric_string_ >>= fun frag -> ~:(unescape frag) end type abs_special_hier = { abs_hier_path: [ net | abs ]; abs_hier_query: string option; } type abs_special = | S_hier of abs_special_hier | S_opaque of string type absolute = { abs_scheme: string; abs_special: abs_special; } let p_hier_part_ = let p_path_ = Cf_parser.alt [ (p_net_path_ >>= fun p -> ~:(`Net p)); (p_abs_path_ >>= fun p -> ~:(`Abs p)); ] in p_path_ >>= fun path -> p_query_ >>= fun query -> ~:{ abs_hier_path = path; abs_hier_query = query } let p_absolute_uri_ = let p_abs_special_ = Cf_parser.alt [ (p_hier_part_ >>= fun x -> ~:(S_hier x)); (p_opaque_part_ >>= fun x -> ~:(S_opaque x)); ] in p_scheme_ >>= fun scheme -> p_colon_ >>= fun _ -> p_abs_special_ >>= fun special -> ~:{ abs_scheme = scheme; abs_special = special } type relative = { rel_path: [ net | abs | rel ]; rel_query: string option; } let empty_segment_ = { seg_params = []; seg_name = "" } let p_relative_uri_ = let p_path_ = Cf_parser.alt [ (p_net_path_ >>= fun x -> ~:(`Net x)); (p_abs_path_ >>= fun x -> ~:(`Abs x)); (p_rel_path_ >>= fun x -> ~:(`Rel x)); ] in ?/ p_path_ >>= fun path -> p_query_ >>= fun query -> let path = match path, query with | None, Some _ -> `Rel (empty_segment_ :: []) | None, None -> `Rel [] | Some path, _ -> path in ~:{ rel_path = path; rel_query = query } type t = | A of absolute | R of relative exception Rel_undefined let normalize_segment_revlist_ = let dotdot_ = ".." in let rec push_loop acc = function | { seg_params = []; seg_name = "." } :: tl -> push_loop acc tl | { seg_params = []; seg_name = ".." } :: (seg :: tl' as tl) -> if seg.seg_params <> [] || seg.seg_name <> dotdot_ then push_loop acc tl' else push_loop (succ acc) tl | x -> acc, x in let rec pop_loop acc = function | _ :: x when acc > 0 -> pop_loop (pred acc) x | x when acc = 0 -> x | _ -> raise Rel_undefined in let rec loop result = function | [] -> result | x -> let n, x = push_loop 0 x in match pop_loop n x with | [] -> result | hd :: tl -> loop (hd :: result) tl in fun x -> List.rev (loop [] x) let refer_relative_to_absolute_path_ base rel = let base = match base with | [] -> [] | _ :: [] -> base | _ :: _ -> match List.rev base with | [] -> assert (not true); [] | _ :: x -> x in let rel = match rel with | { seg_name = "."; seg_params = [] } :: [] -> empty_segment_ :: [] | { seg_name = ".."; seg_params = [] } as dotdot :: [] -> dotdot :: empty_segment_ :: [] | _ -> rel in let revpath = List.rev_append rel base in 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) with | `Net net -> `Net net | `Abs abs -> `Abs abs | `Rel rel -> let abs_hd, abs_tl = abs in `Abs (refer_relative_to_absolute_path_ (abs_hd :: abs_tl) rel) let refer_to_base_net_path_ ~base:(`Net net) ~rel = match (rel.rel_path :> path) with | `Net net -> `Net net | `Abs (hd, tl) -> `Net { net with net_path = hd :: tl } | `Rel rel -> let path_hd, path_tl = refer_relative_to_absolute_path_ net.net_path rel in `Net { net with net_path = path_hd :: path_tl } let refer_to_base ~base ~rel = match base.abs_special with | S_opaque _ -> invalid_arg "Cf_uri.refer_to_base: base URI is opaque." | S_hier abs_hier -> let path = match abs_hier.abs_hier_path with | `Net _ as base -> refer_to_base_net_path_ ~base ~rel | `Abs _ as base -> refer_to_base_abs_path_ ~base ~rel in 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 p_uri_ = Cf_parser.alt [ (p_absolute_uri_ >>= fun x -> ~:(A x)); (p_relative_uri_ >>= fun x -> ~:(R x)); ] let message_to_uri = let p = p_uri_ >>= fun x -> Cf_parser.fin >>= fun _ -> ~:x in fun m -> match p (Cf_message.to_seq m) with | None -> invalid_arg "Cf_uri.message_to_uri: syntax error" | Some (uri, _) -> uri let message_to_absolute_uri ~base message = match message_to_uri message with | R rel -> refer_to_base ~base ~rel | A abs -> abs type reference = { ref_uri: t; ref_fragment: string option; } let p_uri_reference_ = p_uri_ >>= fun uri -> p_fragment_ >>= fun frag -> ~:{ ref_uri = uri; ref_fragment = frag } let message_to_uri_reference = let p = p_uri_reference_ >>= fun x -> Cf_parser.fin >>= fun _ -> ~:x in fun m -> match p (Cf_message.to_seq m) with | None -> invalid_arg "Cf_uri.message_to_uri_reference: syntax error" | Some (uriref, _) -> uriref let message_to_absolute_uri_reference ~base message = let uriref = message_to_uri_reference message in match uriref.ref_uri with | A _ -> uriref | R rel-> let uri = match rel.rel_path with | `Rel [] when rel.rel_query = None -> base | _ -> refer_to_base ~base ~rel in { uriref with ref_uri = A uri } let emit_host pp = function | H_hostname name -> Format.pp_print_string pp (String.lowercase name) | H_ip4_addr addr -> Format.pp_print_string pp (Cf_ip4_addr.ntop addr) let emit_server = let emit_user pp = function | None -> () | Some s -> Format.pp_print_string pp s; Format.pp_print_char pp '@' and emit_port pp = function | None -> () | Some n -> Format.pp_print_int pp n; Format.pp_print_char pp ':' in fun pp srv -> emit_user pp srv.srv_user; emit_host pp srv.srv_host; emit_port pp srv.srv_port let emit_segment_0_ ~allow = let esc_ = escape ~allow in let rec loop pp = function | [] -> () | hd :: tl -> Format.pp_print_char pp ';'; Format.pp_print_string pp (esc_ hd); loop pp tl in fun pp seg -> Format.pp_print_string pp (esc_ seg.seg_name); loop pp seg.seg_params let emit_segment_ = emit_segment_0_ ~allow:ch_is_reserved_in_pchar_ let emit_rel_segment_ = emit_segment_0_ ~allow:ch_is_reserved_in_rel_segment_no_semi_ let rec emit_segment_list_ pp = function | [] -> () | hd :: tl -> Format.pp_print_char pp '/'; emit_segment_ pp hd; emit_segment_list_ pp tl let emit_authority = let esc_ name = escape ~allow:ch_is_reserved_in_userinfo_ name in fun pp auth -> match auth with | A_server None -> () | A_server (Some srv) -> emit_server pp srv | A_reg_name name -> Format.pp_print_string pp (esc_ name) let emit_net_path_ pp net = emit_authority pp net.net_authority; emit_segment_list_ pp net.net_path let emit_path pp = function | `Net net -> Format.pp_print_char pp '/'; Format.pp_print_char pp '/'; emit_net_path_ pp net | `Abs (hd, tl) -> emit_segment_list_ pp (hd :: tl) | `Rel x -> match x with | [] -> () | hd :: tl -> emit_rel_segment_ pp hd; emit_segment_list_ pp tl let emit_abs_special_hier_ = fun pp abs_hier -> emit_path pp abs_hier.abs_hier_path; match abs_hier.abs_hier_query with | None -> () | Some query -> Format.pp_print_char pp '?'; Format.pp_print_string pp query let emit_abs_special = let slash_ = "%2f" in let esc_ s = escape ~allow:ch_is_reserved_ s in fun pp abs -> match abs with | S_hier abs_hier -> emit_abs_special_hier_ pp abs_hier | S_opaque opaque -> let len = String.length opaque in if len > 0 then if (String.unsafe_get opaque 0) = '/' then begin Format.pp_print_string pp slash_; if len > 1 then let opaque = String.sub opaque 1 (pred len) in Format.pp_print_string pp opaque end else Format.pp_print_string pp (esc_ opaque) let emit_absolute_ pp abs = Format.pp_print_string pp abs.abs_scheme; Format.pp_print_char pp ':'; emit_abs_special pp abs.abs_special let emit_relative_ pp rel = emit_path pp rel.rel_path; match rel.rel_query with | None -> () | Some query -> Format.pp_print_char pp '?'; Format.pp_print_string pp query let emit_uri pp = function | A abs -> emit_absolute_ pp abs | R rel -> emit_relative_ pp rel let emit_uri_reference = let esc_ fragment = escape ~allow:ch_is_reserved_ fragment in fun pp uriref -> emit_uri pp uriref.ref_uri; match uriref.ref_fragment with | None -> () | Some fragment -> Format.pp_print_char pp '#'; Format.pp_print_string pp (esc_ fragment) let message_of_uri uri = let b = Buffer.create 80 in let pp = Format.formatter_of_buffer b in emit_uri pp uri; Format.pp_print_flush pp (); let s = Buffer.contents b in Cf_message.create s let message_of_uri_reference uriref = let b = Buffer.create 80 in let pp = Format.formatter_of_buffer b in emit_uri_reference pp uriref; Format.pp_print_flush pp (); let s = Buffer.contents b in Cf_message.create s ;; Gc.compact () (*--- End of File [ cf_uri.ml ] ---*) cf-0.10/cf_uri.mli0000644000175000017500000002131110433520573013670 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_uri.mli Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) (** Operations with Universal Resource Identifier (URI). This module implements types for constructing and deconstructing Universal Resource Identifiers (URI), as well as convenience functions for manipulating their components, and also functions for parsing and emitting them as strings. *) (** {6 Types} *) (** The sum type of "host" components of hierarchical URI's. *) type host = | H_hostname of string | H_ip4_addr of Cf_ip4_addr.opaque Cf_ip4_addr.t (** The type of "server" components of hierarchical URI's. *) type server = { srv_user: string option; (** An optional user name. *) srv_host: host; (** The hostname or IPv4 address. *) srv_port: int option; (** An optional port number. *) } (** The type of "authority" components of hierarchical URI's. *) type authority = | A_server of server option (** Server-based naming authority. *) | A_reg_name of string (** Registry-based naming authority. *) (** The type of path segments in hierarchical URI's. *) type segment = { seg_name: string; (** Segment name. *) seg_params: string list; (** Segment parameters list. *) } (** The type of network paths in hierarchical URI's. *) type net_path = { net_authority: authority; (** Naming authority. *) net_path: segment list; (** List of path segments. *) } (** The type of hierarchical URI network paths. *) type net = [ `Net of net_path ] (** The type of hierarchical URI absolute paths. *) type abs = [ `Abs of segment * segment list ] (** The type of hierarchical URI relative paths. *) type rel = [ `Rel of segment list ] (** The sum type of hierarchical URI paths. *) type path = [ net | abs | rel ] (** The type of absolute hierarchical URI paths with optional query parts. *) type abs_special_hier = { abs_hier_path: [ net | abs ]; (** Path. *) abs_hier_query: string option; (** Query part. *) } (** The sum type of absolute URI parts. *) type abs_special = | S_hier of abs_special_hier (** Hierarchical URI part. *) | S_opaque of string (** Opaque URI part. *) (** The type of absolute URI. *) type absolute = { abs_scheme: string; (** URI scheme name. *) abs_special: abs_special; (** Absolute URI part. *) } (** The type of relative URI. *) type relative = { rel_path: path; (** Path. *) rel_query: string option; (** Query part. *) } (** The type of URI. *) type t = A of absolute | R of relative (** The type of URI references. *) type reference = { ref_uri: t; (** URI *) ref_fragment: string option; (** Optional fragment suffix. *) } (** The exception raised when a relative URI has no defined reference to an absolute URI for a given base, i.e. too many ".." segments. *) exception Rel_undefined (** {6 Functions} *) (** Use [escape ?allow s] to obtain a new string by replacing all the unreserved and "mark" characters in the string [s] with the equivalent URI escape sequence. The optional [allow] function, if specified, can be used to prevent the escape of characters for which the function returns [true]. *) val escape: ?allow:(char -> bool) -> string -> string (** Use [unescape s] to obtain a new string by replacing all the URI escape sequences in the string [s] with the actual character they denote. *) val unescape: string -> string (** Use [refer_to_base ~base ~rel] to compose an absolute URI by directing the relative URI [rel] from the base absolute URI [base]. Raises [Invalid_argument] if the base URI is opaque, and raises [Rel_undefined] if the URI cannot be referred, i.e. too many ".." segments. *) val refer_to_base: base:absolute -> rel:relative -> absolute (** Use [message_to_uri m] to create a URI by parsing the contents of the message [m]. Raises [Invalid_argument] if the message does not contain a valid URI. *) val message_to_uri: Cf_message.t -> t (** Use [message_to_absolute_uri ~base m] to create an absolute URI by parsing the contents of the message [m] and using [base] as the absolute URI for reference in parsing relative URI. Raises [Invalid_argument] if the message does not contain a valid URI, or the base URI is opaque. Raises [Rel_undefined] if the message contains a relative URI that cannot be referred by the base URI. *) val message_to_absolute_uri: base:absolute -> Cf_message.t -> absolute (** Use [message_to_uri_reference m] to create a URI reference by parsing the contents of the message [m]. Raises [Invalid_argument] if the message does not contain a valid URI reference. *) val message_to_uri_reference: Cf_message.t -> reference (** Use [message_to_absolute_uri_reference ~base m] to create a URI reference to an absolute URI by parsing the contents of the message [m] and using [base] as the absolute URI for reference parsing relative URI. Raises [Invalid_argument] if the message does not contain a valid URI, or the base URI is opaque. Raises [Rel_undefined] if the message contains a relative URI that cannot be referred by the base URI. *) val message_to_absolute_uri_reference: base:absolute -> Cf_message.t -> reference (** Use [emit_host pp host] to print the host part of a URI [host] with the formatter [pp]. Reserved characters in the host name are escaped in the output. *) val emit_host: Format.formatter -> host -> unit (** Use [emit_server pp server] to print the server part of a URI [server] with the formatter [pp]. Reserved characters in the host name or user name are escaped in the output. *) val emit_server: Format.formatter -> server -> unit (** Use [emit_authority pp auth] to print the name authority part of a URI [authority] with the formatter [pp]. Reserved characters are escaped appropriately. *) val emit_authority: Format.formatter -> authority -> unit (** Use [emit_path pp path] to print the path component of a URI [path] with the formatter [pp]. Reserved characters in the path segments or path segment parameter lists are escaped in the output. *) val emit_path: Format.formatter -> [< path ] -> unit (** Use [emit_abs_special pp abs] to print the absolute URI specialization [abs] with the formatter [pp]. All reserved characters are escaped appropriately in the output. *) val emit_abs_special: Format.formatter -> abs_special -> unit (** Use [emit_uri pp uri] to print the URI [uri] with the formatter [pp]. All reserved characters are escaped appropriately in the output. *) val emit_uri: Format.formatter -> t -> unit (** Use [emit_uri_reference pp uriref] to print the URI reference [uriref] with the formatter [pp]. All reserved characters are escaped appropriately in the output. *) val emit_uri_reference: Format.formatter -> reference -> unit (** Use [message_of_uri uri] to produce a message containing the formatted URI string produced by emitting [uri] into a string. *) val message_of_uri: t -> Cf_message.t (** Use [message_of_uri_reference uriref] to produce a message containing the formatted URI reference string produced by emitting [uriref] into a string. *) val message_of_uri_reference: reference -> Cf_message.t (*--- End of File [ cf_uri.mli ] ---*) cf-0.10/cf_xxxxx.ml0000644000175000017500000000305610247271231014132 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION cf_xxxxx.ml Copyright (c) 2005, 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. *---------------------------------------------------------------------------*) (*--- End of File [ cf_xxxxx.ml ] ---*) cf-0.10/cf_xxxxx.mli0000644000175000017500000000305310247271231014300 0ustar smimramsmimram(*---------------------------------------------------------------------------* INTERFACE cf_xxxxx.mli Copyright (c) 2005, 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. *---------------------------------------------------------------------------*) (*--- End of File [ cf_xxxxx.mli ] ---*) cf-0.10/cf_xxxxx_p.c0000644000175000017500000000310310115537405014256 0ustar smimramsmimram/*---------------------------------------------------------------------------* C MODULE cf_xxxxx_p.c 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. *---------------------------------------------------------------------------*/ #include "cf_xxxxx_p.h" /*--- End of File [ cf_xxxxx_p.c ] ---*/ cf-0.10/cf_xxxxx_p.h0000644000175000017500000000322610115537405014271 0ustar smimramsmimram/*---------------------------------------------------------------------------* C HEADER cf_xxxxx_p.h 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. *---------------------------------------------------------------------------*/ #ifndef _CF_XXXXX_P_H #define _CF_XXXXX_P_H #include "cf_common_p.h" #endif /* defined(_CF_XXXXX_P_H) */ /*--- End of File [ cf_xxxxx_p.h ] ---*/ cf-0.10/CHANGES0000644000175000017500000006247211021413534012716 0ustar smimramsmimram===== OCaml NAE Core Foundation (cf) library ===== This file describes in technical detail the functional differences between released versions of the library. ===== Version 0.10 ===== Highlights of the changes: + Compatibility with FreeBSD 6.2. + Compatibility with OCaml-3.10.x + Deprecated all the network extension modules, which are now delivered in the Nx library. If you still need them Cf versions, you can restore them by a simple edit of the Makefile. + Changed type of [Cf_gadget.null] to a monad. Added some additional monads. + Renamed [jack] and [plug] to [fix] and [pad], for cosmetic reasons. --- [Cf_gadget] The [null] object is now a monad that producs a null wire. New [connect] and [connectpair] functions are generalizations of the [simplex] and [duplex] functions. Renamed [jack] to [fix]. Renamed [plug] to [pad]. Renamed [gates] to [gate]. ===== Version 0.9 ===== Highlights of the changes: + Compatibility with OCaml-3.10+beta. + Fix bug in Cf_rbtree.nearest_(incr|decr) functions. + Minor performance improvement. + Minor bugs in tests fixed. + Noted that socket extensions and event multiplexing are moving to the forthcoming Nx library. --- [Cf_scan_parser] Upgrade to OCaml-3.10.0. --- [Cf_sbheap] Improve performance of [head]. --- [Cf_rbtree] Fix bug in [Cf_rbtree.nearest_(incr|decr)] causing the whole tree to be returned if there is an exact match for the key. --- [t_cf] Fix T11 and T12 to orderly close the transmit before receiving. Fix typographical errors in diagnostic messages. Add T18 for testing [Cf_rbtree.nearest_(incr|decr)]. ===== Version 0.8 ===== Highlights of the changes: + Fix bugs and remove warnings generated when compiling with OCaml 3.09 series. + Changed named of types to remove [_t] suffixes (that were never a good idea). + Rewrote the gadget monad again, to permit input backtracking on the flow resulting from evaluation. + Minor changes to event polling to simplify interface. + Modularity improvements to socket API. + Update the hard-coded TAI-UTC leap second archive. + Update copyrights and author email address. + Minor improvements to lazy sequences and functional messages. + Removed obsolete modules. --- [Makefile] Use -warn-error A on debug builds. --- [Cf_deque] Use recursive module instead of magic. Add [to_list], [of_list] and [of_seq] convenience functions. --- [Cf_rbtree] Optimizations for better performance. (Further optimizations are possible. While these modules offer more adaptability than the standard OCaml library data structures, they do not offer superior performance. In some cases, performance is a little better than the standard, but in most cases, the standard library is runs faster. This is particularly true for the binary set operator functions.) --- [Cf_ip4_addr,Cf_ip6_addr] Fixed an awful bug in the [compare] functions that caused the return value to be mistyped. --- [Cf_tai64] Update the hard-coded TAI-UTC leap second archive. Add a comment describing where to retrieve the data. --- [Cf_scan_parser] Fix brokenness surfaced by OCaml 3.09 series. --- [Cf_gadget] Re-engineered, again. This time, the integrated state is dropped from the monad, and the scheduler is no longer implemented in the imperative style. As a result, evaluating the monad now produces a flow that permits backtracking on the input. --- [Cf_state_gadget] This is the old [Cf_gadget] from version 0.7, with some minor improvements. Use [try... with] to catch only the [Queue.Empty] exceptions raised by the calls to [Queue.take] in the scheduler itself. All other exceptions are passed through the flow produced by [Cf_gadget.eval]. Added [abort] and [wirepair] monads. Simplified by removing [fsimplex] monad, and the [simplex_t] and [duplex_t] types. --- [Cf_machine] Obsolescent. Use the [start] and [next] classes in [Cf_gadget] instead. --- [Cf_message, Cf_seq] Add [to_function] for convenience constructing [Scanf.scanbuf] objects. The indirection is required to keep [Scanf] from having to be loaded if it isn't used. --- [Cf_journal] Add [`Notice] event level, and associated method in [agent] class. Cleared up some ambiguous language in the documentation. --- [Cf_nameinfo] Interface was busted for all queries except with the default hints. Refined interface to support narrowed queries. --- [Cf_poll] Unified ['a state_t] and ['a file_state_t] into a single concrete variant type and removed the polymorphism on the state variant in all the derived event classes. Event classes are now parameterized by event type alone. Changed [time] class to be a repeating interval timer event. Fixed [idle] so that events that reload themselves are not serviced until the next cycle. --- [Cf_ipX_proto, Cf_xxx_socket] Moved the definitions of the protocol modules into the [Cf_ipX_proto] modules. This will allow [Iom] to link with the core socket API without also linking in all the convenience classes for synchronous I/O. --- [Cf_lexer] Obsolete, therefore removed. --- Changed names of types to remove [_t] suffixes. Module Type names changed ------ ------------------ [Cf_journal] [invalid_t], [fail_t], [error_t], [warn_t], [info_t], [debug_t], [basic_t], [enable_t], [level_t] [Cf_seq] [cell_t] [Cf_flow] [cell_t] [Cf_gadget_t] [work_t], [gate_t], [wire_t], [guard_t] [Cf_lex] [counter_t] [Cf_socket] [socktype_t], [domain_t], [protocol_t], [sockaddr_t], [sockopt_t], [tag_t], [address_t], [msg_flag_t] [Cf_sock_common] [address_t] [Cf_ip4_addr] [network_t] [Cf_ip4_proto] [tag_t], [address_t] [Cf_ip6_proto] [tag_t], [address_t], [mreq_t] [Cf_uri] [host_t], [server_t], [authority_t], [segment_t], [abs_path_v], [rel_path_v], [path_t], [absolute_t], [relative_t], [reference_t] [abs_special_t], [abs_special_hier_t] --- [t_cf] Test Cf_scan_parser.scanfx "%!". ===== Version 0.7 ===== Highlights of the changes: + Some very minor bugs fixed. + Minor performance and improvements. + Additions to [Cf_parser] interface. + Minor modifications to [Cf_parser] and [Cf_lex] interfaces. + New module [Cf_machine]: object-oriented layer over [Cf_gadget]. + Removed trailing underscores from private methods defined in class types for the purpose of establishing a convention. --- [Cf_seq] Added [sentinel]. Added [?x] optional argument to [limit]. --- [Cf_rbtree] Fixed error in [member] that could produce false negatives. --- [Cf_parser] Fixed [to_extended] to work given the new physical equality rules enforced by Ocaml-3.08.X. Still need to write a test case for this. Added [Error] exception and two new functions, [err] and [req], to the [X] module. They do the expected thing. Changed the [err f] function to [err ?f ()] instead. Fix [lit] and [X.lit] to not evaluate past the end of the literal. --- [Cf_scan_parser] Removed unused [this_] member from [scanner] class object. --- [Cf_lex] Change name of [line_cursor] class to [cursor] for simplicity. --- [Cf_message] Fixed [normalize] so that it works even when compiled with -unsafe. Improved performance of [normalize] by verifying the list before filtering. Removed [to_seq2] because it's really not necessary. Added [?x] optional argument to [to_seq] and [limit]. --- [Cf_flow,Cf_rbtree,Cf_parser] Use Cf_seq.nil in place of Lazy.lazy_from_val Cf_seq.Z. --- [Cf_machine] New module. Object-oriented framework for [Cf_gadget] state machines. --- [Cf_poll] Allow subclasses [Cf_poll.file] to have more states. Changed the type parameter of the [event] class to 'state, rather than 'event. Added the rwx_t convenience type, i.e. type rwx_t = [ `R | `W | `X ] --- [Cf_socket] Add [`SOCK_SEQPACKET] to the allowed socket types in the [listen] function. There is no support for that socket type yet, but we must make room for it. When [setsockopt] fails, raise Unix_error with the right function name. --- [Cf_sock_common] Make [setsockopt] and [getsockopt] method explicitly polymorphic. --- [Cf_sock_dgram, Cf_sock_stream] Explicitly specify socket type tags. --- [cf_socket_p.c, cf_ip4_proto_p.c, cf_ip6_proto.c] Use socklen_t instead of other types, in order to shut up compiler warnings when using GCC 4.0. ===== Version 0.6 ===== Highlights of the changes: + More bugs fixed (some critical). --- [Cf_rbtree] Fix bug in [Map.insert] that failed to replace nodes when the key specifies a node that is already in the map. (Thanks to Craig Falls, once again, for finding this bug.) --- [Cf_dfa] Improved lazy DFA module with a better functorial interface, to allow for more efficient symbol maps (to support, e.g. wide character lexers) and to decouple the symbol type from the cursor type, so that Cf_parser.X can be used easily in place of Cf_parser. --- [Cf_dfa, Cf_lexer] Fixed the documentation for the [( $@ )] operator to reflect the actual behavior. When the action parser does not accept the recognized sequence, then no other rule is selected and no other action functions are executed. --- [Cf_lexer] Updated to use the new [Cf_dfa] interface, though it is now deprecated in favor of the new, improved [Cf_lex] module (see below). --- [Cf_uri] Updated to use the new [Cf_lex] in place of the deprecated [Cf_lexer]. --- [various .c files] Rename custom data tags from 'pagoda' to 'ocnae'. + New functions. --- [Cf_rbtree, Cf_set, Cf_map] Add [of_list_incr], [of_list_decr], [of_seq_incr] and [of_seq_decr], which are optimized for lists and sequences known to be in increasing or decreasing order. These functions were derived from code contributed by Brian Hurt (thanks!) and implement a variant on Hinze's algorithm: --- [Cf_set] Add [size] function. --- [Cf_seq] Add [nil] value. Add [flatten] function. Requires Ocaml-3.08 now. --- [Cf_flow] Add [commute_string] function. --- [Cf_parser] Add [of_extended] and [to_extended] functions. Add [req] parser, an efficient shortcut for [alt (p :: err f :: [])]. Add [Error] exception for generic unparameterized errors. Add [altz] parser for match from a sequence (instead of a list) of choices. --- [Cf_scan_parser] Change [scanf] to return an ordinary Cf_parser.t function. Add [scanfx] to return a Cf_parser.X.t function. --- [Cf_regex] New module for regular expression parsing, matching and search. --- [Cf_lex] A new and improved lexical analysis module, with an interface derived from the now deprecated [Cf_lexer]. It offers a more flexible interface to the underlying [Cf_dfa] module, and its [( !~ )] and [( !$ )] operators parse their string arguments as regular subexpressions with the format defined in the new [Cf_regex] module. --- [README] Fixed an embarrassing word-choice bug, i.e. principle vs. principal. ===== Version 0.5 ===== Highlights of the changes: + Many bugs fixed (some critical). + IPv6 socket addresses are now a triple, containing the scope identifier. + Fixed a very bad stack leak problem in the [Cf_gadget] scheduler. --- [Cf_deque] Fix major bug in [fold] that caused a BUS ERROR (ack!), and also fixed [filter] so that it uses the non-recursive [fold] function here instead of going to the extra work of using [Cf_seq.fold]. --- [Cf_rbtree] Fix a bug in [iterate] (found by Craig Falls; thanks Craig!) caused by a stoopid typo. Caused some elements to be iterated twice, and others not at all. --- [Cf_gadget] Moderate surgery on the scheduler to fix a bad stack leak. The new code is probably a tiny bit more efficient too, because I got rid of some unnecessary uses of {Lazy.t} in places, and there is a bit less lifting between monads. I didn't benchmark it, though. --- [Cf_socket] Added a special case for Mac OS X to work around a bug in Apple's network stack that errors in connect(2) on a non-blocking socket do not get in the errno system variable. You have to get them out of the socket with the SO_ERROR socket option. --- [Cf_ip4_addr] Make the network subnet manipulation functions cope with networks that are not unicast networks. (Yes, there are multicast ranges that can be treated like subnets.) --- [Cf_ip6_proto] Add a third element to the socket address type: an int32 for the scope id. --- [Cf_ip6_addr] Fix the [v4compat] and [v4mapped] address type tags so that they are actually polymorphic variants, like they're supposed to be. This was another stoopid typo, but I found it myself. --- [Cf_netif] Fixed the C-language code to call if_nametoindex() with the proper arguments. Again, this was a stoopid typo. --- [Cf_poll] A minor change to the commented bits of debugging code in the middle of the select loop to use [Cf_journal] instead of my [xprintf] hackery. --- {TESTS} Added a test for the [Cf_gadget] scheduler to detect stack leaks. ===== Version 0.4 ===== Highlights of the changes: + Fix Makefile for architectures that do not support native compilers. + Fix major bug in the [Cf_gadget] scheduler that caused some wires to be prematurely collected without delivering events to their receivers. --- [Cf_gadget] Fix major bug in the scheduler. Events transmitted on wires that are no longer connected to a receiver are now delivered to any pending guards that were queued before the receiver was collected. Minor changes to the debugging hints to use Cf_journal. --- [Makefile] Samuel Mimram, the Debain maintainer of this package, says: There are some minor issues with your Makefile concerning non-native archs [...]: - the doc rule should use ocamldoc instead of ocamldoc.opt since it is not available on all archs (or add a optdoc rule); - the install rule should not depend on cf.cmxa and cf.a since they are not necessarly built. Thanks to Mr. Mimram for catching this. ===== Version 0.3 ===== Highlights of the changes: + Rewrite the scheduler in [Cf_gadget] so that it sucks less wind. The kernel is now built entirely out of mutable structures, and we got rid of the 'pin' type because we don't represent wires internally as integer keys in a map. + Added [Cf_journal], a foundation for extensible diagnostic event journaling inspired by Log4j from the Apache Foundation. (Look for a full suite of extensions to be sold separately.) + Removed the [?xf] optional exception function from the [Cf_lexer.create] function. Use a derived cursor class with an [error] method that can be overridden for this purpose. + Added [Cf_scan_parser], which scans an input sequence using the [Scanf] module in the standard library. + Minor convenience functions added to [Cf_parser]. + Other bug fixes. --- [Cf_deque] Apply the iterative function in left-to-right order for all the utility functions. --- [Cf_journal] All new functions. --- [Cf_parser] Added the [filter], [map] and [optmap] functions for transforming parser with higher order functions on their output symbols. --- [Cf_scan_parser] New module, allowing the mixing of [Scanf] and [Cf_lexer] in the same parser/lexer system. --- [Cf_dfa, Cf_lexer] Added new ['i cursor] class. Removed the ['c raise_exn_t] type and the [?xf] optional parameter from the [create] function. --- [Cf_uri] Fixed bug in [refer_to_base] that allowed relative paths to resolve to absolute paths with a [".."] segment at the beginning of the path. Also, changed to throw [Rel_undefined] instead of [Invalid_argument] (as the documentation specifies). Also, use the new [Cf_lexer.cursor] class, as now required. --- [Cf_gadget] Major modifications for new scheduler. The [pin_t] type is no longer. Should be more efficient (and less buggy). --- [all *.c files] Stop abusing Field() as a lvalue in the C primitives. The GC is reputed to hate that, and while we haven't encountered it in this library, we've seen it in others. Best to be safe. Also: stop using CAMLlocalX() in subblocks of functions. Just use them at the top of the main function block. It seems to like that. ===== Version 0.2 ===== Highlights of the changes: + Major overhaul of [Cf_rbtree] to address serious performance issues (should improve performance of [Cf_dfa], [Cf_lexer], [Cf_poll] and [Cf_gadget]). + Defined [Cf_set.T] and [Cf_map.T] module types for use in abstracting the underlying algorithm behind sets and maps. + Added [Cf_seq.constrain] (and [Cf_seq.constrain2] for consistency). + Defined [Cf_heap.T] and [Cf_pqueue.T] module types for use in abstracting the use of skew-binomial heaps as either a heap or a priority queue. Reimplemented the interface to [Cf_sbheap] so it is consistent with the new [Cf_rbtree] interface. --- [new files] Added [Cf_heap], [Cf_map], [Cf_pqueue] (and changed the meaning of the [Cf_set] module to be consistent). These files all contain module types for common data structure algorithms implemented in the {Cf} library. Specific implementations are separated out into other modules. --- [Cf_rbtree] Completely rewritten to address serious performance issues and to combine the interface for both sets and maps. Use the new [Cf_rbtree.Set(K)] and [Cf_rbtree.Map(K)] functors. Most functions now offer better performance for smoothly distributed input than do the [Set] and [Map] modules in the Ocaml standard library. (Note: the [subset] function has been fixed so that it considers its arguments in the same order as the standard library.) --- [Cf_sbheap] Minor modifications to conform to the new [Cf_heap] and [Cf_pqueue] module types. Use the new [Cf_sbheap.Heap(K)] and [Cf_sbheap.PQueue(K)] functors. --- [Cf_ordered] Removed the [KV_Pair_T] module type and its associated functor [KV_Pair], since these types are unecessary. --- [Cf_seq] Added the [constrain] and [constrain2] functions for constraining a sequence to just those elements until the constraining function is false. --- [Cf_dfa Cf_gadget Cf_poll] Modified to use the new [Cf_rbtree] and [Cf_sbheap] interface. --- [t_cf] Added a new test case, that covers [Cf_flow.commute] and a few other things. (Test coverage is still abyssmally poor, if you ask me.) ===== Version 0.1 ===== Highlights of the changes: + Compile and pass self-tests on Suse Linux 9.0. + Unified [sequence] and [accumulate] monad functions in [Cf_seq]. + Added [Cf_exnopt] module with a simple convenience type. + New monadic constructors for [Cf_seq] and [Cf_flow] types. + Moderate overhaul of [Cf_gadget] (fix bugs, design problems). + Fix portability bugs in [Cf_socket] and cognates. + Add support for UDP, IP multicast and network interface selection. + Fix bug in [Cf_poll.idle] event polling (and give a timestamp). + Slightly better self-tests for [Cf_socket]. --- [Cf_cmonad, Cf_smonad, Cf_scmonad] Removed the [sequence] and [accumulate] functions. Use the new functions in [Cf_seq] for this. --- [Cf_exnopt] Added to library. This is a simple sum type useful for defining monads that answer with either a value result or an Ocaml exception. --- [Cf_seq] Added new functions for monadic construction. Use [writeC] to construct a sequence with a continuation monad. Use [writeSC] to construct a sequence with a state-continuation monad. Added new modules, [C] and [SC], containing the [sequence] and [accumulate] functions from [Cf_cmonad] and [Cf_scmonad] respectively. (The functions from [Cf_smonad] have been removed completely.) --- [Cf_flow] Added new function for monadic construction. Use [readC] and [writeC] to construct a flow with a continuation monad. Use [readSC] and [writeSC] to construct a flow with a state-continuation monad. Evaluating a continuation monad or a state-continuation monad with [evalC] or [evalSC] gives a resulting [('i, 'o) Cf_flow.t] value. --- [Cf_gadget] In the [gate0_t] record, removed the [g_ptr_] field and changed the type of the [g_id_] field from an integer to a [pin_t] value. In the [kernel_t] record, changed the [k_rdyq_] field from a queue of [process0_t] values to a queue of [process0_t Lazy.t] values. Use [Cf_cmonad] by references, instead of by copy and paste. Define new class [Cf_gadget.connection] as the common base class of [Cf_gadget.rx] and [Cf_gadget.tx] to contain the [pin] method and two new methods: [check], which returns [false] if the other end of the connection has been collected by the garbage collector; and [id] which returns a text representation of the pin identifier (suitable for use in debug log messages). Removed [zguard] to replace with new [guard] and [rx] interface. The new [rx#get] method returns a [guard_t] continuation monad which is evaluated by the new [guard method]. Internally, this is done by redefining [gate_t] as a continuation monad constructing a sequence of [gate0_t] values (parameterized by state). Optimized [tx#put] so that it does not enter the [scheduler_] function. Only [guard] can invoke a full pass through the scheduler now (though the scheduler could still use improvements for efficiency-- see ISSUES). Fixed an efficiency bug in [write] that unnecessarily constructed continuations. --- [Cf_socket] Many platforms do not have a [sa_len] field in [sockaddr], so we now allocate socket address custom blocks with an extra [size_t] field at the beginning to carry the size of the structure. Stop using buffers of [SOCK_MAXADDRLEN] length and use the structure defined in RFC 3493 instead, i.e. [struct sockaddr_storage]. Some socket options are not available on all platforms; therefore, allow the [opt_get] and [opt_set] fields in an option structure to be NULL if a platform doesn't support them. The [getsockopt] and [setsockopt] function raise [Failure] when those socket options are used on those platforms. The [SO_REUSEPORT] and [SO_NOSIGPIPE] options are not available on Linux. --- [Cf_nameinfo] Removed [ni_withscopeid] from list of flags. This is a Mac OS X extension and I'm not sure how I will support address scoping issues yet. Maybe it comes back later. Changes to handling of [sockaddr] structures to accommodate new representation required for [Cf_socket] functions. Stop using buffers of [SOCK_MAXADDRLEN] length and use the structure defined in RFC 3493 instead, i.e. [struct sockaddr_storage]. --- [Cf_netif] New module. Provides wrapper around [if_nameindex] and cognates. --- [Cf_ip4_addr, Cf_ip6_addr] Fixed several endianness bugs caused by failure to apply (or misapplication of) [ntohX] and [htonX] macros. Linux does not define [IN_LINKLOCAL], so we define it if it's undefined. Linux also does not define [IN6ADDR_NODELOCAL_ALLNODES_INIT], [IN6ADDR_LINKLOCAL_ALLNODES_INIT] or [IN6ADDR_LINKLOCAL_ALLROUTERS_INIT]. Fix error in [cf_ip4_addr_compute_limits]. --- [Cf_ip_common, Cf_ip4_proto, Cf_ip6_proto] Add new protocol number for IPv6. Add [TCP_NODELAY] socket option. Add [Cf_ip4_proto.mreq_t] type for [IP_ADD/DROP_MEMBERSHIP] socket options. Add [Cf_ip6_proto.mreq_t] type for [IPV6_JOIN/LEAVE_GROUP] socket options. Add new socket options for IPv4 sockets: IP_TTL, IP_ADD_MEMBERSHIP, IP_DROP_MEMBERSHIP, IP_MULTICAST_IF, IP_MULTICAST_TTL and IP_MULTICAST_LOOP. Add new socket options for IPv6 sockets: IPV6_UNICAST_HOPS, IPV6_V6ONLY, IPV6_JOIN_GROUP, IPV6_LEAVE_GROUP, IPV6_MULTICAST_IF, IPV6_MULTICAST_HOPS, IPV6_MULTICAST_LOOP. Changes to handling of [sockaddr_in] and [sockaddr_in6] structures to accommodate new representation required for [Cf_socket] functions. Added a new primitive function [Cf_ip4_proto.siocgifaddr] that returns the interface address for a named interface. --- [Cf_sock_common] Remove [send] and [recv] private methods from [Cf_sock_common.basic] class. --- [Cf_sock_stream] Change [send] and [recv] methods on [Cf_sock_stream.endpoint] class from virtual override to simple concrete methods. Use an abbreviation module for [Cf_socket] in the implementation. --- [Cf_sock_dgram] New module for SOCK_DGRAM sockets. --- [Cf_udp4_socket, Cf_udp6_socket] New modules for UDP sockets (both IPv4 and IPv6). --- [Cf_poll] Change [p_idle_queue_] field of [Cf_poll.t] record so that the callback function in each entry of the queue takes a [Cf_tai64n.t] timestamp indicating the timestamp when the idle condition arrived. Fix [cycle] so that idle polls are processed even when no other polls are loaded. ===== Version 0.0 ===== This was the initial release of the library. Major and minor version numbers count upward from zero. Major version numbers with a minor version number of zero indicate the first release in a "stable" branch. Non-zero minor version numbers indicate "development" branches converging on the next stable release. Patches to stable releases are numbered with a third level of numbering. --j h woodyatt cf-0.10/ISSUES0000644000175000017500000001046210456106012012652 0ustar smimramsmimramOpen issues in development: + (unspecified): A GODI package would be nice to promote community adoption. + (Cf_gadget): Write some documentation about polymorphic variants as channel type parameters. + (Cf_poll): Alan Post writes: "When converting [Cf_poll] to use kqueue, I noticed that even after this conversion, the operations don't always scale that well: load unload service fd lg n lg n lg n timer C n C idle C n C In each case, the "n" is the number of registered callbacks of the particular type. The signal callbacks are limited to one per signal slot, so scaling isn't really an applicable issue at the moment. I didn't address that limitation in [Cf_poll] as a part of the kqueue patch because the issues were unrelated. In the same vein, cf_poll currently allows only one callback per fd; this seems sensible to me, but should probably be documented." + (Cf_rbtree): Document the complexity of the [incr_next] and [decr_next] functions. The binary set functions could be improved for performance by using recursive [join] and [split] functions. + (Cf_socket_p): No support for WIN32. SVR4 remains untested, but portability has been substantially improved. Suse Linux 9.0+ may still work. I don't know anymore, since my Linux box died, I replaced it with Mac OS X Server 10.4, and I haven't looked back. + (Cf_socket and cognates): Support for sendmsg() and recvmsg(), and associated IPv4 and IPv6 protocol options that use the control plane for various advanced features of the network protocol stack. + (Cf_socket and cognates): Support for AF_LOCAL. To do this right, we need support for the control plane using sendmsg() and recvmsg(), so we can have file descriptor and user credential passing-- pretty much the only good reasons to use AF_LOCAL other than to communicate with other programs that use them instead of AF_INET on the loopback interface for no good reason. + (Cf_tai64_p, Cf_tai64n_p): No support for 32-bit environments where the C compiler does not offer support for 64-bit integers with 'unsigned long long'. Do such environments exist anymore? + (Cf_tai64,Cf_tai64n,Cf_stdtime): The leap seconds table is currently hard-coded into the .ml file here. What we really need is an active daemon process that keeps a regular check on the IERS bulletins that announce leap seconds. We also need the conversions between UTC and TAI to 1) raise an exception if they correspond to an epoch in the future beyond the expiration of the current IERS bulletin; and 2) optionally perform a calculation based on estimated drift between TAI and UTC. + (Cf_patricia): Is a generalized PATRICIA trie implementation a good idea? If so, is it a good idea to implement sets on both red-black binary trees and on PATRICIA tries and see which one performs better. Further research is in order here. + (Cf_int_patricia): An implementation of PATRICIA tries specialized for integer keys is worth doing separately. Integer sets implemented on PATRICIA tries are probably the best way to get faster integer sets for the [Cf_dfa] module. + (Cf_uri): Need function for converting an absolute path to a relative path for a given base path. + (Unimplemented): Support for I18N and locales. Need timezones especially. The rest we can probably defer to the nice people working on Camomile. + (Cf_nameinfo): There should be a function for acquiring an 'en-US' localized string corresponding to a value of type [unresolved]. + (Cf_gadget): The scheduler might benefit from optimization for scalability. After guard is evaluated once and found to be pending, it should be converted into a map of wire numbers to gate functions. Furthermore, the queue of pending guards should be compressed so that each entry is a map of wire numbers to a record comprised of the pending gate and the guard that contains it. If no wire is gated simultaneously in more than one guard, then the guard queue will never have more than one entry in it, and the scheduler will offer O(log N) complexity, where N is the number of simultaneously pending wires. Note: expiring wires will be an issue. # End of open issues cf-0.10/LICENSE0000644000175000017500000000251410433520572012726 0ustar smimramsmimram Copyright (c) 2002-2006, 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. cf-0.10/Makefile0000644000175000017500000001531610716231173013365 0ustar smimramsmimram# FILE Makefile # # Copyright (c) 2003-2006, 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. REQUIRE = unix PREDICATES = ############################################################################### .PHONY: default opt test test.opt clean install uninstall depend doc default:: #OCAMLFINDOPT = -pp camlp4o -package "$(REQUIRE)" -predicates "$(PREDICATES)" #OCAMLDEP = ocamldep -pp camlp4o OCAMLFINDOPT = -package "$(REQUIRE)" -predicates "$(PREDICATES)" OCAMLC = ocamlfind ocamlc $(OCAMLFINDOPT) OCAMLOPT = ocamlfind ocamlopt $(OCAMLFINDOPT) OCAMLMKLIB = ocamlmklib OCAMLMKTOP = ocamlfind ocamlmktop $(OCAMLFINDOPT) OCAMLDEP = ocamldep OCAMLLEX = ocamllex OCAMLYACC = ocamlyacc OCAMLDOC = ocamlfind ocamldoc $(OCAMLFINDOPT) DEBUG_OPT = -g WARN_ERROR = -passopt -w -passopt Ae # -warn-error A PRINCIPLE = -principal UNSAFE = -unsafe -noassert ALL_OCAML_OPT = $(WARN_ERROR) $(PRINCIPLE) CC_OPT = -ccopt -fPIC -ccopt -O2 -ccopt -Wall -ccopt -Wno-unused-variable # add "-ccopt -I/usr/local/include -ccopt -L/usr/local/lib" for FreeBSD 6.2 CMI_OPT = $(ALL_OCAML_OPT) $(DEBUG_OPT) CMO_OPT = $(ALL_OCAML_OPT) $(DEBUG_OPT) CMX_OPT = $(ALL_OCAML_OPT) $(UNSAFE) -inline 9 .SUFFIXES: .ml .mli .mll .mly .cmo .cmi .cma .cmx .cmxa %.ml : %.mll $(OCAMLLEX) $< %.ml %.mli : %.mly $(OCAMLYACC) -b$* $< %.cmi : %.mli $(OCAMLC) $(CMI_OPT) -o $@ -c $< %.cmi %.cmo : %.ml $(OCAMLC) $(CMO_OPT) -o $@ -c $< %.cmi %.cmx %.o : %.ml $(OCAMLOPT) $(CMX_OPT) -o $@ -c $< %.o : %.c $(OCAMLC) $(CC_OPT) -o $@ -c $< clean:: rm -f *.cmi *.cmo *.cma rm -f *.cmx *.cmxa *.o *.a dll*.so ############################################################################### default:: cf.cma opt:: cf.cmxa CF_LEXYACC_MODULES = CF_YACC_MODULES = $(CF_LEXYACC_MODULES:%=cf_yacc_%) CF_LEX_MODULES = $(CF_LEXYACC_MODULES:%=cf_lex_%) #clean:: # rm -rf $(CF_LEX_ML_FILES) # rm -rf $(CF_YACC_ML_FILES) # rm -rf $(CF_YACC_MLI_FILES) cf_lex_%.cmo : cf_yacc_%.cmi cf_lex_%.cmi cf_lex_%.cmx : cf_yacc_%.cmi cf_lex_%.cmi #manual dependencies #cf_yacc_foo.cmi: cf_foo_bar.cmi #cf_lex_foo.cmi: cf_foo_bar.cmi CF_LEX_ML_FILES = $(CF_LEX_MODULES:%=%.ml) CF_YACC_ML_FILES = $(CF_YACC_MODULES:%=%.ml) CF_YACC_MLI_FILES = $(CF_YACC_MODULES:%=%.mli) CF_MODULES = \ ordered either exnopt smonad cmonad scmonad tai64 tai64n gregorian \ stdtime journal seq deque flow heap pqueue map set sbheap rbtree \ gadget state_gadget machine unicode parser message dfa regex lex \ scan_parser CF_PRIMITIVES = tai64 tai64n #CF_ADDR_MODULES = ip4 ip6 #CF_PROTO_MODULES = ip4 ip6 #CF_MODULES += \ # socket netif nameinfo sock_common sock_dgram sock_stream \ # ip_common $(CF_ADDR_MODULES:%=%_addr) $(CF_PROTO_MODULES:%=%_proto) \ # tcp4_socket tcp6_socket udp4_socket udp6_socket poll uri #CF_PRIMITIVES += \ # common socket netif nameinfo sock_dgram sock_stream \ # ip_common $(CF_ADDR_MODULES:%=%_addr) $(CF_PROTO_MODULES:%=%_proto) CF_ML_FILES = $(CF_MODULES:%=cf_%.ml) CF_MLI_FILES = $(CF_MODULES:%=cf_%.mli) CF_CMI_FILES = $(CF_MODULES:%=cf_%.cmi) CF_CMO_FILES = $(CF_MODULES:%=cf_%.cmo) CF_CMX_FILES = $(CF_MODULES:%=cf_%.cmx) CF_O_FILES = $(CF_MODULES:%=cf_%.o) CF_P_C_FILES = $(CF_PRIMITIVES:%=cf_%_p.c) CF_P_H_FILES = $(CF_PRIMITIVES:%=cf_%_p.h) CF_P_O_FILES = $(CF_PRIMITIVES:%=cf_%_p.o) libcf.a dllcf.so : $(CF_P_O_FILES) # $(CF_CMI_FILES) $(CF_CMO_FILES) $(OCAMLMKLIB) -o cf $(CF_P_O_FILES) cf.cma : libcf.a dllcf.so $(CF_CMI_FILES) $(CF_CMO_FILES) $(OCAMLMKLIB) -o cf $(CF_CMO_FILES) -lcf cf.cmxa cf.a : libcf.a dllcf.so $(CF_CMI_FILES) $(CF_CMX_FILES) $(CF_O_FILES) $(OCAMLMKLIB) -o cf $(CF_CMX_FILES) -lcf install:: libcf.a dllcf.so cf.cma { test ! -f cf.cmxa || extra="cf.cmxa cf.a"; }; \ ocamlfind install cf \ $(CF_MLI_FILES) $(CF_CMI_FILES) $(CF_P_H_FILES) \ cf.cma libcf.a dllcf.so META $$extra uninstall:: ocamlfind remove cf ############################################################################### TEST_MODULES = cf # setbench deq TEST_PROGRAMS = $(TEST_MODULES:%=t.%) TEST_OPT_PROGRAMS = $(TEST_MODULES:%=t-opt.%) TEST_ML_FILES = $(TEST_MODULES:%=t/t_%.ml) TEST_LINKOPT = -cclib -L. -linkpkg TEST_LIBS = cf default:: $(TEST_PROGRAMS) opt:: $(TEST_OPT_PROGRAMS) t.% : t/t_%.ml $(TEST_LIBS:%=%.cma) $(OCAMLC) -o $@ $(CMO_OPT) $(TEST_LINKOPT) $(TEST_LIBS:%=%.cma) $< t-opt.% : t/t_%.ml $(TEST_LIBS:%=%.cmxa) $(OCAMLOPT) -o $@ $(CMX_OPT) $(TEST_LINKOPT) $(TEST_LIBS:%=%.cmxa) $< test:: $(TEST_PROGRAMS) @for i in $(TEST_PROGRAMS); do \ echo; \ echo $$i; \ CAML_LD_LIBRARY_PATH=. ./$$i; \ done test.opt:: $(TEST_OPT_PROGRAMS) @for i in $(TEST_OPT_PROGRAMS); do \ echo; \ echo $$i; \ CAML_LD_LIBRARY_PATH=. ./$$i; \ done clean:: rm -f t/*.cmi t/*.cmo rm -f t/*.cmx t/*.o rm -f t.* t-opt.* ############################################################################### default:: ocamltop ocamltop: $(TEST_LIBS:%=%.cma) $(OCAMLMKTOP) -o $@ $(CMO_OPT) $(TEST_LINKOPT) $(TEST_LIBS:%=%.cma) clean:: rm -f ocamltop ############################################################################### DOC_SOURCES = $(CF_MLI_FILES) $(CF_ML_FILES) doc:: @mkdir -p doc $(OCAMLDOC) -v -d doc -html -colorize-code -m A $(DOC_SOURCES) ############################################################################### DEPEND_FILE=.depend $(DEPEND_FILE) :: $(OCAMLC) -c -ccopt -MM $(CF_P_C_FILES) > .depend $(OCAMLDEP) $(CF_MLI_FILES) $(CF_ML_FILES) $(TEST_ML_FILES) >> .depend depend:: $(DEPEND_FILE) include $(DEPEND_FILE) # End of file [ Makefile ] cf-0.10/META0000644000175000017500000000026511021413640012362 0ustar smimramsmimram# The following META file is a guess by ocamlfind: name="cf" version="0.10" description="OCaml NAE Core Foundation" requires="unix" archive(byte)="cf.cma" archive(native)="cf.cmxa" cf-0.10/README0000644000175000017500000000466310674114607012615 0ustar smimramsmimram===== OCaml NAE Core Foundation (cf) library ===== This distribution is the Objective Caml Network Application Environment (NAE) Core Foundation library, which is a collection of miscellaneous extensions to the Objective Caml standard library. Highlighted features include: - Functional streams and stream processors (extended). - Functional bootstrapped skew-binomial heap. - Functional red-black binary tree (associative array). - Functional sets based on red-black binary tree. - Functional real-time catenable deque. - Functional LL(x) parsing using state-exception monad. - Functional lazy deterministic finite automaton (DFA). - Functional lexical analyzer (using lazy DFA and monadic parser). - Functional substring list manipulation (message buffer chains). - Gregorian calendar date manipulation. - Standard time manipulation. - System time in Temps Atomique International (TAI). - Unicode transcoding. - Universal resource identifier (URI) manipulation. Additionally, the following noteworthy features are provided for compatibility with earlier versions of this library. Further development of these features is expected to move to a new, separate [Nx] library. These features are not expected to improve in the [Cf] library for the version 0.x series, and they will be removed in the 1.x series. - Extended socket interface (supports more options, and UDP w/multicast). - I/O event multiplexing (with Unix.select). Note: see the ISSUES file for a list of open problems in this release. ===== Required Components ===== This library requires the following external components: - Objective Caml (v3.10.0 or newer) - Findlib (tested with v1.1.2p1) Principal development was on Mac OS X 10.4 w/ XCode 2.4.1 using GCC 4.0. Other platforms with POSIX-like environments should require a minimal porting effort. One major open issue: the extended socket interface is broken under WIN32. (The author invites help porting the library to other environments.) ===== Building ===== No 'configure' script is provided. Compile the library with: $ make default Compile both bytecode and native versions with: $ make default opt Execute tests for byte and native versions with: $ make test test.opt Install the library with ocamlfind using: $ make install Uninstall the library with ocamlfind using: $ make uninstall Make the reference documentation with ocamldoc using: $ make doc --j h woodyatt San Francisco, CA cf-0.10/t/0000755000175000017500000000000011021415424012153 5ustar smimramsmimramcf-0.10/t/.cvsignore0000644000175000017500000000003410116504142014150 0ustar smimramsmimram.DS_store *.cmi *.cmo *.cmx cf-0.10/t/t_cf.ml0000644000175000017500000014545610716231173013446 0ustar smimramsmimram(*---------------------------------------------------------------------------* IMPLEMENTATION t_cf.ml Copyright (c) 2003-2006, 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. *---------------------------------------------------------------------------*) Random.self_init ();; let jout = Cf_journal.stdout let _ = jout#setlimit `Notice (* Gc.set { (Gc.get ()) with (* Gc.verbose = 0x3ff; *) Gc.verbose = 0x14; };; Gc.create_alarm begin fun () -> let min, pro, maj = Gc.counters () in Printf.printf "[Gc] minor=%f promoted=%f major=%f\n" min pro maj; flush stdout end *) module T1 = struct module R = Cf_rbtree.Map(Cf_ordered.Int_order) open R let decreasing = to_seq_decr let rec printlist s nl = assert begin let b = Buffer.create 40 in Printf.bprintf b "%s: [" s; List.iter (fun n -> Printf.bprintf b " %d;" n) nl; Printf.bprintf b " ]\n"; jout#debug "%s" (Buffer.contents b) end let to_list tree = Cf_seq.fold (fun v (e, _) -> e :: v) [] (decreasing tree) let testcontent tree lst = printlist "testcontent" lst; let c = to_list tree in if c <> lst then begin printlist "found" c; failwith "testcontent" end let testfind tree key = let msg = Printf.sprintf "testfind %d" key in printlist msg (to_list tree); try let e = search key tree in assert (member key tree); if (e / 2) <> key then failwith "testfind key <> e / 2" with | Not_found -> assert (not (member key tree)); failwith "testfind -> Not_found" let testextract tree key = let msg = Printf.sprintf "testextract %d" key in printlist msg (to_list tree); try let e, nt = extract key tree in if (e / 2) <> key then failwith "testextract -> e <> key"; nt with | Not_found -> failwith "testextract -> Not_found" let test0 () = let t1, old = insert (1, 2) nil in if old <> None then failwith "t1 replaced a nil"; testcontent t1 [ 1 ]; testfind t1 1; let d1 = testextract t1 1 in testcontent d1 []; let t2, old = insert (2, 4) t1 in if old <> None then failwith "t2 replaced a nil"; testcontent t2 [ 1; 2 ]; testfind t2 1; testfind t2 2; let d1 = testextract t2 1 in testcontent d1 [ 2 ]; let d2 = testextract t2 2 in testcontent d2 [ 1 ]; let d12 = testextract d1 2 in testcontent d12 []; let d21 = testextract d2 1 in testcontent d21 []; let t3, old = insert (3, 6) t2 in if old <> None then failwith "t3 replaced a nil"; testfind t3 1; testfind t3 2; testfind t3 3; let d1 = testextract t3 1 in testcontent d1 [ 2; 3 ]; let d2 = testextract t3 2 in testcontent d2 [ 1; 3 ]; let d3 = testextract t3 3 in testcontent d3 [ 1; 2 ]; testfind d1 3; testfind d1 2; testfind d2 1; testfind d2 3; testfind d3 1; testfind d3 2; let d12 = testextract d1 2 in testcontent d12 [ 3 ]; let d23 = testextract d2 3 in testcontent d23 [ 1 ]; let d31 = testextract d3 1 in testcontent d31 [ 2 ]; testfind d12 3; testfind d23 1; testfind d31 2; let d123 = testextract d12 3 in let d231 = testextract d23 1 in let d312 = testextract d31 2 in testcontent d123 []; testcontent d231 []; testcontent d312 []; () let test () = test0 () end module T2 = struct module S1 = Set.Make(Cf_ordered.Int_order) module S2 = Cf_rbtree.Set(Cf_ordered.Int_order) let bound = 64 let iterations = 512 (* let print_list = let rec loop = function | [] -> () | hd :: [] -> Printf.printf "%d" hd | hd :: tl -> Printf.printf "%d; " hd; loop tl in fun id r -> Printf.printf "%s [ " id; loop r; print_string " ]\n"; flush stdout *) let rec loop n s1 s2 = let x = Random.int bound in let msg, s1, s2 = if S1.mem x s1 then "remove failure", S1.remove x s1, S2.clear x s2 else "add failure", S1.add x s1, S2.put x s2 in let n = pred n in let e1 = S1.elements s1 and e2 = S2.to_list_incr s2 in (* print_list "e1" e1; print_list "e2" e2; *) if e1 <> e2 then failwith msg; if n > 0 then loop n s1 s2 let test () = loop iterations S1.empty S2.nil end module T3 = struct module M = Cf_rbtree.Map(Cf_ordered.Int_order) let test1 () = let m = M.replace (0, "zero") M.nil in let s = M.search 0 m in assert (s = "zero"); assert (M.member 0 m) let nearest_succ key m = match Lazy.force (M.nearest_incr key m) with | Cf_seq.Z -> raise Not_found | Cf_seq.P (hd, _) -> hd let nearest_pred key m = match Lazy.force (M.nearest_decr key m) with | Cf_seq.Z -> raise Not_found | Cf_seq.P (hd, _) -> hd let test2 () = let m = [ 1, "one"; 3, "three"; 5, "five"; 7, "seven"; 9, "nine"; 11, "eleven"; 13, "thirteen"; 15, "fifteen"; 17, "seventeen"; 19, "nineteen"; ] in let m = M.of_list_incr m in if nearest_succ 0 m <> (1, "one") then failwith "nearest_succ 0"; if nearest_succ 1 m <> (1, "one") then failwith "nearest_succ 01"; if nearest_succ 2 m <> (3, "three") then failwith "nearest_succ 2"; if nearest_pred 20 m <> (19, "nineteen") then failwith "nearest_pred 20"; if nearest_pred 19 m <> (19, "nineteen") then failwith "nearest_pred 19"; if nearest_pred 18 m <> (17, "seventeen") then failwith "nearest_pred 18"; () let test () = test1 (); test2 (); end module T4 = struct (* open Cf_vwdeque *) (* open Cf_kotdeque *) open Cf_deque let aux msg i _ (* q *) = assert begin (* jout#debug "%s i=%d q=%s\n" msg i (sprint string_of_int q) *) (**) jout#debug "%s i=%d\n" msg i (**) end let modaux msg modulo i q = if ((i / modulo) * modulo) = i then aux msg i q let test1 pop push = let n = 1024 in let rec loop1 i q = aux "+" i q; if i < n then loop1 (succ i) (push i q) else loop2 0 q and loop2 i q = (* aux "-" i q; *) if i < n then begin match pop q with | None -> failwith "[1] pop: None" | Some (j, q) -> if i <> j then jout#fail "[1] i <> j j=%d" j; loop2 (succ i) q end else match pop q with | None -> () | Some _ -> failwith "[1] pop: Some _" in loop1 0 nil let test2 pop push ncat = let size = 10000 (* and m = 1 *) in let chunk = 100 in let rec cons i q = function | j when j > 0 -> (* modaux "+" m i q; *) cons (succ i) (push i q) (pred j) | _ -> i, q in let rec load i j z = let i, j, q0, q1 = if z > chunk then begin let z = z / chunk in let z = if z < chunk then chunk else z in let i, j, q0 = load i j z in let i, j, q1 = load i j z in i, j, q0, q1 end else begin assert (z = chunk); let x = Random.int z in let x = if x > j then j else x in let j = j - x in let i, q0 = cons i nil x in let y = Random.int z in let y = if y > j then j else y in let j = j - y in let i, q1 = cons i nil y in i, j, q0, q1 end in let q' = ncat q0 q1 in (* aux "%" i q'; *) if j > 0 && z > chunk then begin let i, j, q = load i j z in let q' = ncat q' q in (* aux "%" i q'; *) i, j, q' end else i, j, q' in let rec unload i q = (* modaux "-" m i q; *) if i < size then begin match pop q with | None -> failwith "[2] pop: None" | Some (j, q) -> if i <> j then failwith (Printf.sprintf "[2] i <> j i=%d j=%d" i j); unload (succ i) q end else match pop q with | None -> () | Some _ -> failwith "[2] pop: Some _" in let i, j, q = load 0 size size in if i <> size then failwith "[2] load: i <> size"; if j <> 0 then failwith "[2] load: j <> 0"; unload 0 q let test () = test1 A.pop B.push; test1 B.pop A.push; test2 A.pop B.push catenate; test2 B.pop A.push (fun q2 q1 -> catenate q1 q2); () end module T5 = struct open Cf_seq let (!$) s = Cf_seq.head s, Cf_seq.tail s let test () = let s = of_substring "abc" 0 in let ch, s = !$ s in if ch <> 'a' then failwith "next 0"; let _ = !$ s in let ch, s = !$ s in if ch <> 'b' then failwith "next 1"; let _ = !$ s in let _ = !$ s in let ch, s = !$ s in if ch <> 'c' then failwith "next 2"; try ignore (!$ s); failwith "terminal" with Cf_seq.Empty -> () end module T6 = struct open Printf open Cf_lex.Op open Cf_parser.Op module L1 = struct let test1 lexer = let token0 = "abaabaababbabb" in let input = token0 (* ^ "jhw" *) in let s = Cf_seq.of_substring input 0 in let token, s' = match lexer s with | Some x -> x | None -> failwith "No match! [L1.1]" in if Lazy.force s' <> Cf_seq.Z then failwith "Unexpected trailer [1]!"; if token <> token0 then failwith (sprintf "Bad match! [msg='%s']" token) let test2 lexer = let token0 = "abaabaababbabb" in let input = token0 ^ "jhw" in let s = Cf_seq.of_substring input 0 in let token, s' = match lexer s with | Some x -> x | None -> failwith "No match! [L1.2]" in if Lazy.force s' = Cf_seq.Z then failwith "Expected trailer [2]!"; if token <> token0 then failwith (sprintf "Bad match! [msg='%s']" token) end module L2 = struct let p = let q0 = Cf_scan_parser.scanf "%3u" (fun y -> y) in let q1 = Cf_scan_parser.scanf "%c" (fun y -> y) in let q2 = Cf_scan_parser.scanf "%3u" (fun y -> y) in q0 >>= fun v0 -> q1 >>= fun v1 -> q2 >>= fun v2 -> ~:(v0, v1, v2) let y s = p (Cf_seq.of_string s) let test () = match y "1234567" with | Some ((123, '4', 567), z) when Lazy.force z = Cf_seq.Z -> () | Some ((123, '4', 567), z) -> failwith (Cf_seq.to_string z) | Some ((v0, v1, v2), _) -> failwith (Printf.sprintf "%02u, '%c', %02u" v0 v1 v2) | _ -> failwith "No match! [L2]" end module L3 = struct let qlist_ = [ "abc", "abc"; "(a*b+c?.[`t +?]|d)", "`(a`*b`+c`?`.`[``t `+`?`]`|d`)"; ] let loop (a, b) = let s = Cf_flow.commute_string Cf_regex.unquote b in if s <> a then failwith (Printf.sprintf "unquoting \"%s\" <> \"%s\"" s a); let s = Cf_flow.commute_string Cf_regex.quote a in if s <> b then failwith (Printf.sprintf "quoting \"%s\" <> \"%s\"" s b); () let test () = List.iter loop qlist_ end module L4 = struct let lex = Cf_lex.create !@[ !$"`s+" $= None; !$"`w+" $> (fun x -> Some x); ] let rec loop acc z = match lex z with | None -> Some (List.rev acc, z) | Some (None, z) -> loop acc z | Some (Some tok, z) -> loop (tok :: acc) z let p = loop [] >>= fun arr -> Cf_parser.fin >>= fun () -> ~:arr let input_ = "bim bam boom" let test () = let s = Cf_seq.of_string input_ in match p s with | Some ([ "bim"; "bam"; "boom" ], s) when Lazy.force s = Cf_seq.Z -> () | _ -> failwith "parse error!" end module L5 = struct let xlist = [ "a", [ "a" ], [ "x"; "ax"; "" ]; "abc", [ "abc" ], [ "xxxx" ]; "[abc]+", [ "abccabc" ], [ "abcdabcd" ]; "ab+c*d?e", [ "abe"; "abbcde" ], [ "ae"; "acde"; "xxxx" ]; "a(bc)+d", [ "abcd"; "abcbcd" ], [ "abc"; "abcabc"; "abcdd" ]; "(a|b)*abb", [ "abababb"; "ababbabb" ], [ "ababab"; "cde" ]; "[_`a][_`i]*", [ "id0"; "_"; "long_id" ], [ "0"; "" ]; "[ `t]*`w+", [ "foo"; "\t foo" ], [ "\n"; " "; "" ]; ] let yes_ s x v = if not (Cf_regex.test x v) then jout#fail "Expected '%s' to match expression '%s'." v s let no_ s x v = if Cf_regex.test x v then jout#fail "Expected '%s' to match expression '%s'." v s let test1 (s, yes, no) = let x = Cf_regex.of_string s in List.iter (yes_ s x) yes; List.iter (no_ s x) no let test () = List.iter test1 xlist end let test () = let lexer = Cf_lex.create begin (!*(!:'a' $| !:'b')) $& !$"abb" $> (fun x -> x) end in L1.test1 lexer; L1.test2 lexer; L2.test (); L3.test (); L4.test (); L5.test () end module T7 = struct open Cf_parser.Op let digit = let zero = int_of_char '0' in let sat = Cf_parser.sat (function '0'..'9' -> true | _ -> false) in sat >>= fun ch -> ~:((int_of_char ch) - zero) let unumber = let rec to_int x = function | [] -> x | hd :: tl -> to_int (hd + (x * 10)) tl in ?+digit >>= fun (d0, dn) -> ~:(to_int 0 (d0 :: dn)) let plus = ?. '+' let minus = ?. '-' let mult = ?. '*' let div = ?. '/' let lparen = ?. '(' let rparen = Cf_parser.alt [ ?. ')'; Cf_parser.err ~f:(fun _ -> failwith "Expected ')'") (); ] let number = Cf_parser.alt [ unumber; begin plus >>= fun _ -> unumber >>= fun n -> ~:n end; begin minus >>= fun _ -> unumber >>= fun n -> ~:(-n) end; ] type fval_t = Mul of int | Div of int let rec expr s = Cf_parser.alt [ begin term >>= fun hd -> ?*expr_c >>= fun tl -> ~:(List.fold_left (+) hd tl) end; term; ] s and expr_c s = Cf_parser.alt [ begin plus >>= fun _ -> term >>= fun n -> ~:n end; begin minus >>= fun _ -> term >>= fun n -> ~:(-n) end; ] s and term = let f a = function Mul x -> a * x | Div x -> a / x in fun s -> Cf_parser.alt [ begin factor >>= fun hd -> ?*term_c >>= fun tl -> ~:(List.fold_left f hd tl) end; term; ] s and term_c s = Cf_parser.alt [ begin mult >>= fun _ -> factor >>= fun n -> ~:(Mul n) end; begin div >>= fun _ -> factor >>= fun n -> if n = 0 then failwith "Div 0"; ~:(Div n) end; ] s and factor s = Cf_parser.alt [ begin lparen >>= fun _ -> expr >>= fun e -> rparen >>= fun _ -> ~:e end; number ] s let run s = begin expr >>= fun e -> Cf_parser.fin >>= fun () -> ~:e end s let calc s = match run (Cf_seq.of_string s) with | Some (o, tl) when Lazy.force tl = Cf_seq.Z -> o | Some _ -> failwith "Unparsed trailer" | None -> failwith "Parse error" let positive = [ "123", 123; "-256", -256; "2+3", 5; "8/(4-2)+1", 5; ] let t_pos (s, x) = let x' = calc s in if x' <> x then begin let msg = Printf.sprintf "'%s' <> %d (%d)" s x x' in failwith msg end let test () = List.iter t_pos positive end module T8 = struct module L1 = struct module C = Cf_cmonad open C.Op module type M = sig val get_int: (unit, int) C.t val get_line: (unit, string) C.t val get_float: (unit, float) C.t val put_int: int -> (unit, unit) C.t val put_string: string -> (unit, unit) C.t val put_float: float -> (unit, unit) C.t end module M: M = struct let get_int f = f (read_int ()) let get_line f = f (read_line ()) let get_float f = f (read_float ()) let put_int n f = f (print_int n) let put_string s f = f (print_string s) let put_float x f = f (print_float x) end let get_name = M.put_string "What is your name? " >>= fun _ -> M.get_line let get_color = M.put_string "What is your favorite color? " >>= fun _ -> M.get_line let get_foo = M.put_string "What is a continuation monad? " >>= fun _ -> M.get_line let query = get_name >>= fun name -> get_color >>= fun color -> get_foo >>= fun foo -> M.put_string (Printf.sprintf "%s, %s, %s\n" name color foo) let test () = print_string ">>> L1\n"; C.eval query (); print_string "<<< L1\n"; end module L2 = struct module C = Cf_cmonad module SC = Cf_scmonad open SC.Op module type M = sig val get_int: (int, unit, int) SC.t val get_line: (int, unit, string) SC.t val get_float: (int, unit, float) SC.t val put_int: int -> (int, unit, unit) SC.t val put_string: string -> (int, unit, unit) SC.t val put_float: float -> (int, unit, unit) SC.t end module M: M = struct let get_int f y = f (read_int ()) y let get_line f y = f (read_line ()) y let get_float f y = f (read_float ()) y let put_int n f y = f (print_int n) y let put_string s f y = f (print_string s) y let put_float x f y = f (print_float x) y end let get_name = SC.load >>= fun n -> let msg = Printf.sprintf "[%d] What is your name? " n in M.put_string msg >>= fun _ -> SC.store (succ n) >>= fun _ -> M.get_line let get_color = SC.load >>= fun n -> let msg = Printf.sprintf "[%d] What is your favorite color? " n in M.put_string msg >>= fun _ -> SC.store (succ n) >>= fun _ -> M.get_line let get_foo = SC.load >>= fun n -> let msg = Printf.sprintf "[%d] What is a state continuation monad? " n in M.put_string msg >>= fun _ -> SC.store (succ n) >>= fun _ -> M.get_line let query = get_name >>= fun name -> get_color >>= fun color -> get_foo >>= fun foo -> M.put_string (Printf.sprintf "%s, %s, %s\n" name color foo) let test () = print_string ">>> L2\n"; let c = C.Op.( >>= ) (SC.down query 0) begin fun s -> C.return (Printf.printf "state=%d\n" s) end in C.eval c (); print_string "<<< L2\n"; end let test () = (* L1.test (); L2.test (); *) assert true end module T9_old = struct (* let rec logflow w = match Lazy.force w with | Cf_flow.Z -> print_string "| Z\n"; flush stdout; Cf_flow.Z | Cf_flow.P (hd, tl) -> (* if (int_of_float hd) mod 1000 = 0 then begin *) Printf.printf "| P %f\n" hd; flush stdout; (* end; *) Cf_flow.P (hd, lazy (logflow tl)) | Cf_flow.Q f -> Cf_flow.Q begin fun i -> Printf.printf "| Q %d\n" i; flush stdout; logflow (lazy (f i)) end let rec circuit0 = Cf_flow.Q begin fun n -> let hd = (float_of_int n) /. 2.0 in let tl = Lazy.lazy_from_val circuit0 in Cf_flow.P (hd, tl) end *) open Cf_cmonad.Op open Cf_state_gadget let rec divider i o = let i = (i :> ('a, int, float) rx) in let o = (o :> ('b, int, float) tx) in let rec loop () = guard begin i#get begin fun (`I n) -> load >>= fun state -> store (succ state) >>= fun () -> let oval = (float_of_int n) /. 2.0 in o#put (`O oval) >>= fun () -> loop () end end in loop () let ingest isrc = let isrc = (isrc :> ('a, int, float) tx) in let rec loop () = read >>= fun i -> isrc#put (`I i) >>= loop in loop () let render osnk = let osnk = (osnk :> ('a, int, float) rx) in let rec loop () = guard begin osnk#get begin fun (`O n) -> write n >>= loop end end in loop () let gadget x = simplex >>= fun (efRx, efTx) -> simplex >>= fun (enRx, enTx) -> start (ingest enTx) () >>= fun () -> start (render efRx) () >>= fun () -> start (divider enRx efTx) x let input = let rec loop n = Cf_seq.P (n, lazy (loop (succ n))) in fun () -> lazy (loop 1) let output = let rec loop n = let x = (float_of_int n) /. 2.0 in Cf_seq.P (x, lazy (loop (succ n))) in fun () -> lazy (loop 1) open Cf_flow.Op let test () = let n = 100 in let i = Cf_seq.limit n (input ()) in let o = Cf_seq.limit n (output ()) in let divflow = eval (gadget 0) () in (* let divflow = lazy (logflow divflow) in *) let x = Cf_flow.to_seq (Cf_flow.of_seq i -=- divflow) in if not (Cf_seq.equal x o) then failwith "Transform failed!" end module T9 = struct (* let rec logflow w = match Lazy.force w with | Cf_flow.Z -> print_string "| Z\n"; flush stdout; Cf_flow.Z | Cf_flow.P (hd, tl) -> (* if (int_of_float hd) mod 1000 = 0 then begin *) Printf.printf "| P %f\n" hd; flush stdout; (* end; *) Cf_flow.P (hd, lazy (logflow tl)) | Cf_flow.Q f -> Cf_flow.Q begin fun i -> Printf.printf "| Q %d\n" i; flush stdout; logflow (lazy (f i)) end let rec circuit0 = Cf_flow.Q begin fun n -> let hd = (float_of_int n) /. 2.0 in let tl = Lazy.lazy_from_val circuit0 in Cf_flow.P (hd, tl) end *) open Cf_cmonad.Op open Cf_gadget class divider i o = let i = (i :> ('a, int, float) rx) in let o = (o :> ('b, int, float) tx) in object(self) inherit [int, float] start inherit [int, float] next val count = 0 method private input (`I n) = o#put (`O ((float_of_int n) /. 2.0)) >>= fun () -> {< count = succ count >}#next method private guard = i#get self#input end let ingest isrc = let isrc = (isrc :> ('a, int, float) tx) in let rec loop () = read >>= fun i -> isrc#put (`I i) >>= loop in loop () let render osnk = let osnk = (osnk :> ('a, int, float) rx) in let rec loop () = guard begin osnk#get begin fun (`O n) -> write n >>= loop end end in loop () let gadget () = simplex >>= fun (efRx, efTx) -> simplex >>= fun (enRx, enTx) -> start (ingest enTx) >>= fun () -> start (render efRx) >>= fun () -> let m = new divider enRx efTx in m#start let input = let rec loop n = Cf_seq.P (n, lazy (loop (succ n))) in fun () -> lazy (loop 1) let output = let rec loop n = let x = (float_of_int n) /. 2.0 in Cf_seq.P (x, lazy (loop (succ n))) in fun () -> lazy (loop 1) open Cf_flow.Op let test () = let n = 100 in let i = Cf_seq.limit n (input ()) in let o = Cf_seq.limit n (output ()) in let divflow = eval (gadget ()) in (* let divflow = lazy (logflow divflow) in *) let x = Cf_flow.to_seq (Cf_flow.of_seq i -=- divflow) in if not (Cf_seq.equal x o) then failwith "Transform failed!" end module T10 = struct (* 3fffe33e1b840309 365 Sun -1000000-12-31 23:59:59 +0000 3fffe33e1b84030a 000 Mon -999999-01-01 00:00:00 +0000 3ffffff1868b8409 364 Fri -1-12-31 23:59:59 +0000 3ffffff1868b840a 000 Sat 0-01-01 00:00:00 +0000 3ffffff1886e1757 000 Mon 1-01-01 01:01:01 +0000 3ffffff8df7db65f 000 Wed 1000-01-01 12:04:37 +0000 3ffffffec03dbf89 364 Tue 1799-12-31 23:59:59 +0000 3fffffff7c558189 364 Sun 1899-12-31 23:59:59 +0000 3fffffff7c55818a 000 Mon 1900-01-01 00:00:00 +0000 3fffffffffffffff 364 Wed 1969-12-31 23:59:49 +0000 4000000000000000 364 Wed 1969-12-31 23:59:50 +0000 4000000000000009 364 Wed 1969-12-31 23:59:59 +0000 400000000000000a 000 Thu 1970-01-01 00:00:00 +0000 400000000000000b 000 Thu 1970-01-01 00:00:01 +0000 4000000004b25808 181 Fri 1972-06-30 23:59:58 +0000 4000000004b25809 181 Fri 1972-06-30 23:59:59 +0000 4000000004b2580a 181 Fri 1972-06-30 23:59:60 +0000 4000000004b2580b 182 Sat 1972-07-01 00:00:00 +0000 4000000004b2580c 182 Sat 1972-07-01 00:00:01 +0000 4000000030e7241b 364 Sun 1995-12-31 23:59:58 +0000 4000000030e7241c 364 Sun 1995-12-31 23:59:59 +0000 4000000030e7241d 364 Sun 1995-12-31 23:59:60 +0000 4000000030e7241e 000 Mon 1996-01-01 00:00:00 +0000 4000000030e7241d 364 Sun 1995-12-31 23:59:60 +0000 4000000030e7241e 000 Mon 1996-01-01 00:00:00 +0000 4000000030e7241f 000 Mon 1996-01-01 00:00:01 +0000 4000000030e72420 000 Mon 1996-01-01 00:00:02 +0000 4000000033b8489d 180 Mon 1997-06-30 23:59:59 +0000 4000000033b8489e 180 Mon 1997-06-30 23:59:60 +0000 4000000033b8489f 181 Tue 1997-07-01 00:00:00 +0000 4000000033df0226 210 Wed 1997-07-30 08:57:43 +0000 4000000034353637 275 Fri 1997-10-03 18:14:48 +0000 4000000037d77955 251 Thu 1999-09-09 09:09:09 +0000 40000000386d439f 364 Fri 1999-12-31 23:59:59 +0000 40000000386d43a0 000 Sat 2000-01-01 00:00:00 +0000 40000000386d43a1 000 Sat 2000-01-01 00:00:01 +0000 4000000038bb0c1f 058 Mon 2000-02-28 23:59:59 +0000 4000000038bc5d9f 059 Tue 2000-02-29 23:59:59 +0000 4000000038bc5da0 060 Wed 2000-03-01 00:00:00 +0000 400000003a4fc89f 365 Sun 2000-12-31 23:59:59 +0000 40000000f4875017 000 Fri 2100-01-01 17:42:15 +0000 40000001b09f1217 000 Wed 2200-01-01 17:42:15 +0000 40000007915fc517 000 Wed 3000-01-01 17:42:15 +0000 4000003afff53a97 000 Sat 10000-01-01 17:42:15 +0000 40001ca4f3758a1f 364 Fri 999999-12-31 23:59:59 +0000 40001ca4f3758a20 000 Sat 1000000-01-01 00:00:00 +0000 *) module L1 = struct open Cf_stdtime let x = [ "0x400000000000000a", { year = 1970; month = 1; day = 1; hour = 0; minute = 0; second = 0; }; "0x4000000004b2580a", { year = 1972; month = 6; day = 30; hour = 23; minute = 59; second = 60; }; "0x4000000004b2580b", { year = 1972; month = 7; day = 1; hour = 0; minute = 0; second = 0; }; "0x4000000004b2580c", { year = 1972; month = 7; day = 1; hour = 0; minute = 0; second = 1; }; "0x4000000030e7241b", { year = 1995; month = 12; day = 31; hour = 23; minute = 59; second = 58; }; "0x4000000030e7241c", { year = 1995; month = 12; day = 31; hour = 23; minute = 59; second = 59; }; ] let tsprintf j = let mjd = Cf_gregorian.to_mjd ~year:j.year ~month:j.month ~day:j.day in Printf.sprintf "{ mjd=%d %04d-%02d-%02d %02d:%02d:%02d }" mjd j.year j.month j.day j.hour j.minute j.second let y (i, j) = (* Printf.printf "TAI epoch+%s, %s\n" i (tsprintf j); flush stdout; *) let i = Cf_tai64.add_int64 Cf_tai64.first (Int64.of_string i) in let j' = utc_of_tai64 i in if j <> j' then failwith (tsprintf j'); let i' = utc_to_tai64_unsafe ~year:j.year ~month:j.month ~day:j.day ~hour:j.hour ~minute:j.minute ~second:j.second in if i <> i' then let n = Cf_tai64.sub i' Cf_tai64.first in failwith (Int64.format "0x%016x" n) end let test () = List.iter L1.y L1.x end module T11 = struct open Cf_scmonad.Op module String_set = Cf_rbtree.Set(String) (* val memoize: (string, string) Cf_flow.t *) let memoize = let rec loop () = Cf_flow.readSC >>= fun s -> Cf_scmonad.load >>= fun u -> if String_set.member s u then loop () else let u = String_set.put s u in Cf_scmonad.store u >>= fun () -> Cf_flow.writeSC s >>= fun () -> loop () in Cf_flow.evalSC (loop ()) String_set.nil (* val uniq: string list -> string list *) let uniq s = let z = Cf_seq.of_list s in let z = Cf_flow.commute memoize z in Cf_seq.to_list z let test () = let s1 = [ "Hello"; "World!"; "Hello"; "AGAIN!" ] in let s2 = [ "Hello"; "World!"; "AGAIN!" ] in let s2' = uniq s1 in if s2 <> s2' then failwith "Error in uniq!" end module T12 = struct open Cf_state_gadget open Cf_cmonad.Op let gadget limit = read >>= fun () -> duplex >>= fun ((inRx, outTx), (outRx, inTx)) -> let inRx = (inRx :> (unit, unit, unit) rx) in let outTx = (outTx :> (unit, unit, unit) tx) in let outRx = (outRx :> (unit, unit, unit) rx) in let inTx = (inTx :> (unit, unit, unit) tx) in inTx#put () >>= fun () -> wrap inRx outTx Cf_flow.nop >>= fun () -> let rec loop () = guard begin outRx#get begin fun () -> load >>= fun n -> if n < limit then begin (* if n mod 1000 = 0 then begin Printf.printf "n=%08u\n" n; flush stdout end; *) store (succ n) >>= fun () -> inTx#put () >>= loop end else Cf_cmonad.nil end end in start (loop ()) 0 let test () = let limit = 10000 in let gc = Gc.get () in Gc.set { gc with Gc.stack_limit = 4 * 0x400 }; let w = eval (gadget limit) () in match Lazy.force w with | Cf_flow.Q f -> let _ = f () in Gc.set gc | _ -> failwith "Cf_state_gadget not evaluated to Cf_flow.Q state." end module T13 = struct module M = Cf_rbtree.Map (Cf_ordered.Int_order) let test1a () = let tree = M.of_list (List.map (fun a -> (a,())) [9;1;8;3;7;5;4]) in let list = Cf_seq.to_list (Cf_seq.first (M.nearest_incr 6 tree)) in match list with | [ 7; 8; 9 ] -> () | _ -> print_char '['; List.iter (Printf.printf " %d;") list; print_string " ]"; print_newline (); failwith "Cf_rbtree.nearest_incr error [6]!" let test1b () = let tree = M.of_list (List.map (fun a -> (a,())) [9;1;8;3;7;5;4]) in let list = Cf_seq.to_list (Cf_seq.first (M.nearest_incr 5 tree)) in match list with | [ 5; 7; 8; 9 ] -> () | _ -> print_char '['; List.iter (Printf.printf " %d;") list; print_string " ]"; print_newline (); failwith "Cf_rbtree.nearest_incr error [5]!" let test2 n = let tree = M.of_list (List.map (fun a -> (a,())) [9;1;8;3;7;5;4]) in let list = Cf_seq.to_list (Cf_seq.first (M.nearest_decr n tree)) in match list with | [ 5; 4; 3; 1 ] -> () | _ -> print_char '['; List.iter (Printf.printf " %d;") list; print_string " ]"; print_newline (); jout#fail "Cf_rbtree.nearest_decr error [%d]!" n let test () = test1a (); test1b (); test2 5; test2 6 end (* module T14 = struct open Cf_gadget open Cf_cmonad.Op let gadget limit = read >>= fun () -> duplex >>= fun ((inRx, outTx), (outRx, inTx)) -> let inRx = (inRx :> (unit, unit, unit) rx) in let outTx = (outTx :> (unit, unit, unit) tx) in let outRx = (outRx :> (unit, unit, unit) rx) in let inTx = (inTx :> (unit, unit, unit) tx) in inTx#put () >>= fun () -> wrap inRx outTx Cf_flow.nop >>= fun () -> let rec loop () = guard begin outRx#get begin fun () -> load >>= fun n -> if n < limit then begin (* if n mod 1000 = 0 then begin Printf.printf "n=%08u\n" n; flush stdout end; *) store (succ n) >>= fun () -> inTx#put () >>= loop end else Cf_cmonad.nil end end in start (loop ()) 0 let test () = let limit = 10000 in let gc = Gc.get () in Gc.set { gc with Gc.stack_limit = 4 * 0x400 }; let w = eval (gadget limit) () in match Lazy.force w with | Cf_flow.Q f -> let _ = f () in Gc.set gc | _ -> failwith "Cf_state_gadget not evaluated to Cf_flow.Q state." end *) (* module Obsolete_1 = struct module V6 = Cf_ip6_addr open Printf let v6_unicast_cases = [ "::DEAD:BEEF:D00D", V6.U_reserved; "::1", V6.U_loopback; "4000::1", V6.U_unassigned; "::10.0.1.1", V6.U_v4compat; "::FFFF:17.201.23.45", V6.U_v4mapped; "2002::1", V6.U_global; "FE80::203:93ff:feba:7eba", V6.U_link; "FEC0::1", V6.U_site; "::224.0.0.1", V6.U_reserved; ] let v6_unicast_test () = List.iter begin fun (addr, fmt) -> match V6.pton addr with | Some addr' -> if fmt <> V6.unicast_format (V6.is_unicast addr') then failwith (sprintf "V6.unicast_format %s" addr) | None -> failwith (sprintf "unrecognized %s" addr) end v6_unicast_cases let test () = v6_unicast_test () end module Obsolete_2 = struct let len = 10 let test () = try let bind = (Cf_ip4_addr.loopback :> Cf_ip4_addr.opaque Cf_ip4_addr.t), 0 in let listen = new Cf_tcp4_socket.listener bind in listen#listen 1; let bind = listen#getsockname in let active = new Cf_tcp4_socket.initiator bind in active#connect; let a, _ = listen#accept in let a = new Cf_tcp4_socket.endpoint a in let b = new Cf_tcp4_socket.endpoint (active#socket) in a#setsockopt Cf_ip_common.tcp_nodelay true; b#setsockopt Cf_ip_common.tcp_nodelay true; let laddr = a#getpeername and raddr = b#getsockname in let lhost, lport = laddr in let rhost, rport = raddr in if lhost <> rhost then failwith "O2 error: host a#getpeername <> b#getsockname"; if lport <> rport then failwith "O2 error: port a#getpeername <> b#getsockname"; let laddr = a#getsockname and raddr = b#getpeername in let lhost, lport = laddr in let rhost, rport = raddr in if lhost <> rhost then failwith "O2 error: host a#getsockname <> b#getpeername"; if lport <> rport then failwith "O2 error: port a#getsockname <> b#getpeername"; let tx = String.make len 'x' and rx = String.create len in let n = a#send tx 0 len in if n <> len then failwith "O2 error: tx incomplete!"; a#shutdown Unix.SHUTDOWN_SEND; let n = b#recv rx 0 len in if n <> len then failwith "O2 error: rx incomplete!"; if tx <> rx then failwith "O2 error: tx <> rx!"; a#close; b#close; listen#close with | Unix.Unix_error (e, fn, _) -> failwith (Printf.sprintf "O2 error: %s in %s.\n" (Unix.error_message e) fn) end module Obsolete_3 = struct let len = 10 let test () = try let bind = (Cf_ip6_addr.loopback :> Cf_ip6_addr.opaque Cf_ip6_addr.t), 0, 0l in let listen = new Cf_tcp6_socket.listener bind in listen#listen 1; let bind = listen#getsockname in let active = new Cf_tcp6_socket.initiator bind in active#connect; let a = new Cf_tcp6_socket.endpoint (active#socket) in let b, _ = listen#accept in let b = new Cf_tcp6_socket.endpoint b in a#setsockopt Cf_ip_common.tcp_nodelay true; b#setsockopt Cf_ip_common.tcp_nodelay true; let laddr = a#getpeername and raddr = b#getsockname in let lhost, lport, lscope = laddr in let rhost, rport, rscope = raddr in if lhost <> rhost then failwith "O3 error: host a#getpeername <> b#getsockname"; if lport <> rport then failwith "O3 error: port a#getpeername <> b#getsockname"; if lscope <> rscope then failwith "O3 error: port a#getpeername <> b#getsockname"; let laddr = a#getsockname and raddr = b#getpeername in let lhost, lport, lscope = laddr in let rhost, rport, rscope = raddr in if lhost <> rhost then failwith "O3 error: host a#getsockname <> b#getpeername"; if lport <> rport then failwith "O3 error: port a#getsockname <> b#getpeername"; if lscope <> rscope then failwith "O3 error: port a#getsockname <> b#getpeername"; let tx = String.make len 'x' and rx = String.create len in let n = a#send tx 0 len in if n <> len then failwith "O3 error: tx incomplete!"; a#shutdown Unix.SHUTDOWN_SEND; let n = b#recv rx 0 len in if n <> len then failwith "O3 error: rx incomplete!"; if tx <> rx then failwith "O3 error: tx <> rx!"; a#close; b#close; listen#close with | Unix.Unix_error (e, fn, _) -> failwith (Printf.sprintf "O3 error: %s in %s.\n" (Unix.error_message e) fn) end module Obsolete_4 = struct open Cf_uri module L1 = struct let test () = () end module L2 = struct (* http://a/b/c/d;p?q *) let base = { abs_scheme = "http"; abs_special = S_hier { abs_hier_query = Some "q"; abs_hier_path = `Net { net_authority = A_server (Some { srv_user = None; srv_host = H_hostname "a"; srv_port = None; }); net_path = [ { seg_name = "b"; seg_params = [] }; { seg_name = "c"; seg_params = [] }; { seg_name = "d"; seg_params = [ "p" ] }; ]; }; }; } let basestr = Cf_message.contents (message_of_uri (A base)) let resolve_list = [ "g:h" , "g:h"; "g" , "http://a/b/c/g"; "./g" , "http://a/b/c/g"; "g/" , "http://a/b/c/g/"; "/g" , "http://a/g"; "//g" , "http://g"; "?y" , "http://a/b/c/?y"; "g?y" , "http://a/b/c/g?y"; "#s" , "http://a/b/c/d;p?q#s"; "g#s" , "http://a/b/c/g#s"; "g?y#s" , "http://a/b/c/g?y#s"; ";x" , "http://a/b/c/;x"; "g;x" , "http://a/b/c/g;x"; "g;x?y#s" , "http://a/b/c/g;x?y#s"; "." , "http://a/b/c/"; "./" , "http://a/b/c/"; ".." , "http://a/b/"; "../" , "http://a/b/"; "../g" , "http://a/b/g"; "../.." , "http://a/"; "../../" , "http://a/"; "../../g" , "http://a/g"; ] let resolve (relstr, expectstr) = let rel = Cf_message.create relstr in let result = message_to_absolute_uri_reference ~base rel in let resultstr = Cf_message.contents (message_of_uri_reference result) in if resultstr <> expectstr then begin let s = Printf.sprintf "reference URI resolution error \ [rel=\"%s\" expect=\"%s\" result=\"%s\"\n" relstr expectstr resultstr in failwith s end; ignore (message_of_uri_reference result) let unresolved_list = [ "http://a", "../b"; ] let unresolved (basestr, relstr) = let base = message_to_uri (Cf_message.create basestr) in let rel = message_to_uri (Cf_message.create relstr) in let base = match base with | A base -> base | _ -> invalid_arg "base not absolute" in let rel = match rel with | R rel -> rel | _ -> invalid_arg "rel not relative" in try ignore (refer_to_base ~base ~rel); failwith "expected to catch Rel_undefined." with | Rel_undefined -> () let test () = if basestr <> "http://a/b/c/d;p?q" then failwith "base URI emit error"; List.iter resolve resolve_list; List.iter unresolved unresolved_list end let test () = L1.test (); L2.test (); end module Obsolete_5 = struct open Cf_poll class clock n dt = object inherit [unit] time dt as super val mutable count_ = n method private service _ = let tai, frac = Cf_tai64n.decompose epoch_ in let utc = Cf_stdtime.utc_of_tai64 tai in jout#info "O5.clock#service: %04u-%02u-%02u %02u:%02u:%02u.%06u " utc.Cf_stdtime.year utc.Cf_stdtime.month utc.Cf_stdtime.day utc.Cf_stdtime.hour utc.Cf_stdtime.minute utc.Cf_stdtime.second frac; if count_ > 0 then begin count_ <- pred count_; state_ end else Cf_poll.Final () method count = count_ end class interrupt n dt = object(self:'self) inherit [int] signal Sys.sigint as super val clock_ = new clock n dt method private load_ p = clock_#load p; super#load_ p method private unload_ p = super#unload_ p; clock_#unload method private service _ = clock_#unload; Cf_poll.Final clock_#count method canget = if not super#canget then begin if not clock_#canget then false else begin self#unload; state_ <- Cf_poll.Final 0; true end end else begin clock_#unload; true end end let test () = let e = new interrupt 10 0.05 in let p = create () in e#load p; let save = Unix.sigprocmask Unix.SIG_SETMASK [] in let more = ref More in while not e#canget do if !more <> More then failwith "!More"; more := cycle p done; if !more = More then more := cycle p; if !more <> Last then failwith "!Last"; ignore (Unix.sigprocmask Unix.SIG_SETMASK save) end *) let main () = let tests = [ T1.test; T2.test; T3.test; T4.test; T5.test; T6.test; T7.test; T8.test; T9.test; T10.test; T11.test; T12.test; T13.test; (*; T15.test *) (* Obsolete_1.test; Obsolete_2.test; Obsolete_3.test; Obsolete_4.test; Obsolete_5.test; *) ] in Printf.printf "1..%d\n" (List.length tests); flush stdout; let test i f = begin try (* let tms0 = Unix.times () in *) f (); (* let tms1 = Unix.times () in let ut = tms1.Unix.tms_utime -. tms0.Unix.tms_utime in let st = tms1.Unix.tms_stime -. tms0.Unix.tms_stime in Printf.printf "ok %d (ut=%f st=%f)\n" i ut st *) Printf.printf "ok %d\n" i with | Failure(s) -> Printf.printf "not ok %d (Failure \"%s\")\n" i s | x -> Printf.printf "not ok %d\n" i; flush stdout; raise x end; flush stdout; succ i in let _ = List.fold_left test 1 tests in exit 0 ;; main ();; (*--- End of File [ t_cf.ml ] ---*) cf-0.10/t/t_deq.ml0000644000175000017500000000645210115535227013617 0ustar smimramsmimram(*---------------------------------------------------------------------------* TEST t_deq.ml Copyright (c) 2003, 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. *---------------------------------------------------------------------------*) module type Deque_T = sig type 'a t val nil: 'a t module type Direction_T = sig val push: 'a -> 'a t -> 'a t val pop: 'a t -> ('a * 'a t) option end module A: Direction_T module B: Direction_T val catenate: 'a t -> 'a t -> 'a t val sprint: ('a -> string) -> 'a t -> string end module Test(D: Deque_T) = struct open D let loop ~x ~y ~z = let q = ref nil in for i = 1 to x do q := B.push i !q done; let k = ref 1 in for i = 1 to z do let q' = ref nil in for j = 1 to !k do incr k; if !k = y then k := 1; q' := match A.pop !q with | Some (hd, tl) -> q := tl; B.push hd !q' | None -> failwith "Deque error" done; q := catenate !q !q' done let test ~n ~x ~y ~z = for i = 1 to n do loop ~x ~y ~z done end module Kot_test = Test(Cf_kotdeque) module Vw_test = Test(Cf_vwdeque) let push = ref 1000 let pop = ref 100 let cat = ref 5000 let iterations = ref 1 let test = ref Vw_test.test let usage = "usage: t.deq [options] { kot | vw }\n" let speclist = [ "-n", Arg.Int (fun n -> iterations := n), "iterations"; "-x", Arg.Int (fun x -> push := x), "# push"; "-y", Arg.Int (fun y -> push := y), "# pop per catenation"; "-z", Arg.Int (fun z -> push := z), "# catenations" ] let anonarg s = test := if s = "kot" then Kot_test.test else if s = "vw" then Vw_test.test else failwith usage let main () = Arg.parse speclist anonarg usage; !test ~n:!iterations ~x:!push ~y:!pop ~z:!cat; exit 0 ;; main ();; (*--- End of File [ t_deq.ml ] ---*) cf-0.10/t/t_setbench.ml0000644000175000017500000002774010450665161014647 0ustar smimramsmimram (* Comparison functors. *) (* open Time *) open Printf module type MinimalSet = sig type t val empty : t val mem : int -> t -> bool val add : int -> t -> t val remove : int -> t -> t val union : t -> t -> t val inter : t -> t -> t val diff : t -> t -> t val subset : t -> t -> bool val compare : t -> t -> int val fold : (int -> 'a -> 'a) -> t -> 'a -> 'a end module Dummy_set = struct type t = unit let empty = () let mem _ () = true let add _ () = () let remove _ () = () let union () () = () let inter () () = () let diff () () = () let subset () () = true let compare () () = 0 let fold _ () x = x end module type Comparison = sig val check : unit -> unit val timings : unit -> unit end module BenchSet (S : MinimalSet) = struct include S let build_seq n = let rec build i acc = if i == n then acc else build (succ i) (S.add i acc) in build 0 S.empty let seq_10000 = build_seq 10000 let build_rnd m n = Random.init 17; let rec build i acc = if i == n then acc else build (succ i) (S.add (Random.int m) acc) in build 0 S.empty let rnd_10000 = build_rnd 10000 10000 let lookup_seq_seq n = for i = 1 to n do let _ = S.mem (i mod 10000) seq_10000 in () done let lookup_rnd_seq n = Random.init 17; for i = 1 to n do let _ = S.mem ((Random.int n) mod 10000) seq_10000 in () done let lookup_seq_rnd n = for i = 1 to n do let _ = S.mem (i mod 10000) rnd_10000 in () done let lookup_rnd_rnd n = Random.init 17; for i = 1 to n do let _ = S.mem ((Random.int n) mod 10000) rnd_10000 in () done let remove_seq_seq n = let rec rm acc i = if i == n then acc else rm (S.remove i acc) (i + 1) in for i = 1 to 100 do ignore (rm seq_10000 0) done let remove_seq_rnd n = let rec rm acc i = if i == n then acc else rm (S.remove i acc) (i + 1) in for i = 1 to 100 do ignore (rm rnd_10000 0) done let remove_rnd_seq n = Random.init 17; let rec rm acc i = if i == n then acc else rm (S.remove (Random.int n) acc) (i + 1) in for i = 1 to 100 do ignore (rm seq_10000 0) done let remove_rnd_rnd n = Random.init 17; let rec rm acc i = if i == n then acc else rm (S.remove (Random.int n) acc) (i + 1) in for i = 1 to 100 do ignore (rm rnd_10000 0) done let bench_op op n = Random.init 17; for i = 1 to n do ignore (op (build_rnd n (Random.int i)) (build_rnd n (Random.int i))) done let bench_union = bench_op S.union let bench_inter = bench_op S.inter let bench_diff = bench_op S.diff let bench_subset = bench_op S.subset let bench_compare = bench_op S.compare end module Dummy_bench = struct let name = "Dummy" include BenchSet(Dummy_set) end let utime f n = let before = Cf_tai64n.now () in let x = f n in let after = Cf_tai64n.now () in let dt = Cf_tai64n.sub after before in x, dt let compare_times f1 f2 f3 f4 f5 f6 n = Printf.printf "%8d " n; flush stdout; let (_,u1) = utime f1 n in Printf.printf "%8.2f " u1; flush stdout; let (_,u2) = utime f2 n in Printf.printf "%8.2f " u2; flush stdout; let (_,u3) = utime f3 n in Printf.printf "%8.2f " u3; flush stdout; let (_,u4) = utime f4 n in Printf.printf "%8.2f" u4; flush stdout; let (_,u5) = utime f5 n in Printf.printf "%8.2f" u5; flush stdout; let (_,u6) = utime f6 n in Printf.printf "%8.2f" u6; flush stdout; Printf.printf "\n" let compare_times2 f1 f2 f3 f4 f5 f6 n m = compare_times (f1 n) (f2 n) (f3 n) (f4 n) (f5 n) (f6 n) m (* the sets implementations *) (* Ocaml's AVLs *) module S1 = struct module S = Set.Make(struct type t = int let compare x y = y - x end) type t = S.t let empty = S.empty let mem s = S.mem s let inter s1 s2 = S.inter s1 s2 let remove x s = S.remove x s let add x s = S.add x s let compare s1 s2 = S.compare s1 s2 let subset s1 s2 = S.subset s1 s2 let diff s1 s2 = S.diff s1 s2 let union s1 s2 = S.union s1 s2 let fold f s a = S.fold (fun x y -> f x y) s a end module B1 = struct let name = "Ocaml" include BenchSet(S1) end (* James Woodyatt's red-black trees *) module S2 = struct module S = Cf_rbtree.Set(Cf_ordered.Int_order) type t = S.t let empty = S.nil let mem s = S.member s let inter s1 s2 = S.intersect s1 s2 let remove x s = S.clear x s let add x s = S.put x s let compare s1 s2 = S.compare s1 s2 let subset s1 s2 = S.subset s1 s2 let diff s1 s2 = S.diff s1 s2 let union s1 s2 = S.union s1 s2 let fold f s a = S.fold (fun x y -> f y x) a s end module B2 = struct let name = "Cf_rbtree.Set" include BenchSet(S2) end module S3 = Dummy_set module B3 = Dummy_bench module S4 = Dummy_set module B4 = Dummy_bench module S5 = Dummy_set module B5 = Dummy_bench module S6 = Dummy_set module B6 = Dummy_bench module S7 = Dummy_set module B7 = Dummy_bench (**** (* red-black trees *) module S2 = Rbset.Make(struct type t = int let compare = compare end) module B2 = struct let name = "RBT" include BenchSet(S2) end (* Patricia trees *) module S3 = Ptset module B3 = struct let name = "Patricia" include BenchSet(S3) end (* SML red-black trees *) module S4 = Sml_rbt.Make(struct type t = int let compare (x,y) = let c = compare x y in if c < 0 then Sml_rbt.LESS else if c = 0 then Sml_rbt.EQUAL else Sml_rbt.GREATER end) module B4 = struct let name = "SML-RBT" include BenchSet(S4) end (* James Woodyatt's red-black trees *) module S5 = struct let name = "JW-RBT" include Cf_rbset.Create(Cf_ordered.Int_order) let empty = null let mem = member let inter = intersect let remove = clear let add = put let fold f s a = fold (fun x y -> f y x) a s end module B5 = struct let name = "JW-RBT" include BenchSet(S5) end (* extracted AVLs *) module S6 = struct open Avl_extr module Int = struct type t = int let compare x y = let c = compare x y in if c < 0 then Lt else if c == 0 then Eq else Gt end module M = Avl_extr.Make(Int) include M let compare x y = match M.compare x y with Lt -> -1 | Eq -> 0 | Gt -> 1 end module B6 = struct let name = "extr-AVL" include BenchSet(S6) end (* extracted red-black trees *) module S7 = struct open Rbt_extr module Int = struct type t = int let compare x y = let c = compare x y in if c < 0 then Lt else if c == 0 then Eq else Gt end module M = Rbt_extr.Make2(Int) include M let compare x y = match M.compare x y with Lt -> -1 | Eq -> 0 | Gt -> 1 end module B7 = struct let name = "extr-RBT" include BenchSet(S7) end ****) (* correctness check *) let _ = printf "correctness check... "; flush stdout; for i = 1 to 10000 do let b = S1.mem i B1.rnd_10000 in assert (b == S2.mem i B2.rnd_10000); (* assert (b == S3.mem i B3.rnd_10000); assert (b == S4.mem i B4.rnd_10000); assert (b == S5.mem i B5.rnd_10000); assert (b == S6.mem i B6.rnd_10000) *) done; printf "ok\n\n"; flush stdout let _ = printf " %8s %8s %8s %8s %8s %8s\n" B1.name B2.name B3.name B4.name B5.name B6.name; printf "==============================================================\n"; flush stdout let _ = printf "add:\n"; flush stdout; printf "Sequential insertion\n"; flush stdout; compare_times B1.build_seq B2.build_seq B3.build_seq B4.build_seq B5.build_seq B6.build_seq 1000; compare_times B1.build_seq B2.build_seq B3.build_seq B4.build_seq B5.build_seq B6.build_seq 10000; compare_times B1.build_seq B2.build_seq B3.build_seq B4.build_seq B5.build_seq B6.build_seq 100000; compare_times B1.build_seq B2.build_seq B3.build_seq B4.build_seq B5.build_seq B6.build_seq 1000000; printf "Random insertion (few clashes)\n"; flush stdout; compare_times2 B1.build_rnd B2.build_rnd B3.build_rnd B4.build_rnd B5.build_rnd B6.build_rnd 1000 1000; compare_times2 B1.build_rnd B2.build_rnd B3.build_rnd B4.build_rnd B5.build_rnd B6.build_rnd 10000 10000; compare_times2 B1.build_rnd B2.build_rnd B3.build_rnd B4.build_rnd B5.build_rnd B6.build_rnd 100000 100000; compare_times2 B1.build_rnd B2.build_rnd B3.build_rnd B4.build_rnd B5.build_rnd B6.build_rnd 1000000 1000000; printf "Random insertion (many clashes)\n"; flush stdout; compare_times2 B1.build_rnd B2.build_rnd B3.build_rnd B4.build_rnd B5.build_rnd B6.build_rnd 10 1000; compare_times2 B1.build_rnd B2.build_rnd B3.build_rnd B4.build_rnd B5.build_rnd B6.build_rnd 100 10000; compare_times2 B1.build_rnd B2.build_rnd B3.build_rnd B4.build_rnd B5.build_rnd B6.build_rnd 1000 100000; compare_times2 B1.build_rnd B2.build_rnd B3.build_rnd B4.build_rnd B5.build_rnd B6.build_rnd 10000 1000000; printf "\n"; printf "mem:\n"; flush stdout; printf "Sequential lookup in sequential set\n"; compare_times B1.lookup_seq_seq B2.lookup_seq_seq B3.lookup_seq_seq B4.lookup_seq_seq B5.lookup_seq_seq B6.lookup_seq_seq 5000000; printf "Random lookup in sequential set\n"; compare_times B1.lookup_rnd_seq B2.lookup_rnd_seq B3.lookup_rnd_seq B4.lookup_rnd_seq B5.lookup_rnd_seq B6.lookup_rnd_seq 5000000; printf "Sequential lookup in random set\n"; compare_times B1.lookup_seq_rnd B2.lookup_seq_rnd B3.lookup_seq_rnd B4.lookup_seq_rnd B5.lookup_seq_rnd B6.lookup_seq_rnd 5000000; printf "Random lookup in random set\n"; compare_times B1.lookup_rnd_rnd B2.lookup_rnd_rnd B3.lookup_rnd_rnd B4.lookup_rnd_rnd B5.lookup_rnd_rnd B6.lookup_rnd_rnd 5000000; printf "\n"; printf "remove:\n"; flush stdout; printf "Sequential remove in sequential set\n"; compare_times B1.remove_seq_seq B2.remove_seq_seq B3.remove_seq_seq B4.remove_seq_seq B5.remove_seq_seq B6.remove_seq_seq 10000; printf "Random remove in sequential set\n"; compare_times B1.remove_rnd_seq B2.remove_rnd_seq B3.remove_rnd_seq B4.remove_rnd_seq B5.remove_rnd_seq B6.remove_rnd_seq 10000; printf "Sequential remove in random set\n"; compare_times B1.remove_seq_rnd B2.remove_seq_rnd B3.remove_seq_rnd B4.remove_seq_rnd B5.remove_seq_rnd B6.remove_seq_rnd 10000; printf "Random remove in random set\n"; compare_times B1.remove_rnd_rnd B2.remove_rnd_rnd B3.remove_rnd_rnd B4.remove_rnd_rnd B5.remove_rnd_rnd B6.remove_rnd_rnd 10000; printf "\n"; printf "compare:\n"; flush stdout; compare_times B1.bench_compare B2.bench_compare B3.bench_compare B4.bench_compare B5.bench_compare B6.bench_compare 100; compare_times B1.bench_compare B2.bench_compare B3.bench_compare B4.bench_compare B5.bench_compare B6.bench_compare 1000; compare_times B1.bench_compare B2.bench_compare B3.bench_compare B4.bench_compare B5.bench_compare B6.bench_compare 3000; printf "\n"; printf "union:\n"; flush stdout; compare_times B1.bench_union B2.bench_union B3.bench_union B4.bench_union B5.bench_union B6.bench_union 100; compare_times B1.bench_union B2.bench_union B3.bench_union B4.bench_union B5.bench_union B6.bench_union 1000; compare_times B1.bench_union B2.bench_union B3.bench_union B4.bench_union B5.bench_union B6.bench_union 3000; printf "\n"; printf "inter:\n"; flush stdout; compare_times B1.bench_inter B2.bench_inter B3.bench_inter B4.bench_inter B5.bench_inter B6.bench_inter 2000; printf "\n"; printf "diff:\n"; flush stdout; compare_times B1.bench_diff B2.bench_diff B3.bench_diff B4.bench_diff B5.bench_diff B6.bench_diff 2000; printf "\n"; printf "subset:\n"; flush stdout; compare_times B1.bench_subset B2.bench_subset B3.bench_subset B4.bench_subset B5.bench_subset B6.bench_subset 100; compare_times B1.bench_subset B2.bench_subset B3.bench_subset B4.bench_subset B5.bench_subset B6.bench_subset 1000; compare_times B1.bench_subset B2.bench_subset B3.bench_subset B4.bench_subset B5.bench_subset B6.bench_subset 3000; printf "\n"; ()