Commits

Anonymous committed 2fe2bc0

Add a definition of 'let jout = Cf_journal.stdout;; jout#setlimit `None;;'
to the preamble.

  • Participants
  • Parent commits c7a57f5
  • Branches PAGODA

Comments (0)

Files changed (1)

 (*---------------------------------------------------------------------------*
   IMPLEMENTATION  t_cf.ml
 
-  Copyright (c) 2003, James H. Woodyatt
+  Copyright (c) 2003-2004, James H. Woodyatt
   All rights reserved.
 
   Redistribution and use in source and binary forms, with or without
 
 Random.self_init ();;
 
+(**)
+let jout = Cf_journal.stdout;;
+jout#setlimit `None;;
+(**)
+
 (*
 Gc.set {
     (Gc.get ()) with
 *)
 
 module T1 = struct
-    module R = Cf_rbtree.Create(Cf_ordered.Int_order)
+    module R = Cf_rbtree.Map(Cf_ordered.Int_order)
     open R
     
+    let decreasing = to_seq_decr
+    
     let rec printlist s nl =
         (*
         Printf.printf "%s: [" s;
 end
 
 module T2 = struct
-    open Cf_set
+    (* open Cf_rbset *)
         
     module S1 = Set.Make(Cf_ordered.Int_order)
-    module S2 = Cf_set.Create(Cf_ordered.Int_order)
+    module S2 = Cf_rbtree.Set(Cf_ordered.Int_order)
     
     let bound = 64
     let iterations = 512
                 "add failure", S1.add x s1, S2.put x s2
         in
         let n = pred n in
-        let e1 = S1.elements s1 and e2 = S2.elements s2 in
+        let e1 = S1.elements s1 and e2 = S2.to_list_incr s2 in
         (*
         print_list "e1" e1;
         print_list "e2" e2;
         if n > 0 then loop n s1 s2
     
     let test () =
-        loop iterations S1.empty S2.null
+        loop iterations S1.empty S2.nil
 end
 
 module T3 = struct
-    module IntOrder = struct type t = int let compare = compare end
-    module M = Cf_rbtree.Create(IntOrder)
+    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")
     
+    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";
             19, "nineteen";
         ] in
         let m = M.of_list m in
-        if M.nearest_succ 0 m <> (1, "one") then
+        if nearest_succ 0 m <> (1, "one") then
             failwith "nearest_succ 0";
-        if M.nearest_succ 1 m <> (1, "one") then
+        if nearest_succ 1 m <> (1, "one") then
             failwith "nearest_succ 01";
-        if M.nearest_succ 2 m <> (3, "three") then
+        if nearest_succ 2 m <> (3, "three") then
             failwith "nearest_succ 2";
-        if M.nearest_pred 20 m <> (19, "nineteen") then
+        if nearest_pred 20 m <> (19, "nineteen") then
             failwith "nearest_pred 20";
-        if M.nearest_pred 19 m <> (19, "nineteen") then
+        if nearest_pred 19 m <> (19, "nineteen") then
             failwith "nearest_pred 19";
-        if M.nearest_pred 18 m <> (17, "seventeen") then
+        if nearest_pred 18 m <> (17, "seventeen") then
             failwith "nearest_pred 18";
         ()
     
 
 module T6 = struct
     open Printf
-    
+    open Cf_lexer.Op
+    open Cf_parser.Op
+        
     module L1 = struct
-        open Cf_lexer.Op
-        open Cf_parser.Op
-        
-        let lexer = Cf_lexer.create begin
-            (!*(!:'a' $| !:'b')) $& !$"abb" $^ (fun x -> x)
-        end
-        
         let cursor_ = new Cf_lexer.line_cursor "\n"
         
-        let test1 () =
+        let test1 lexer =
             let token0 = "abaabaababbabb" in
             let input = token0 (* ^ "jhw" *) in
             let s = Cf_seq.of_substring input 0 in
             if token <> token0 then
                 failwith (sprintf "Bad match! [msg='%s']" token)
         
-        let test2 () =
+        let test2 lexer =
             let token0 = "abaabaababbabb" in
             let input = token0 ^ "jhw" in
             let s = Cf_seq.of_substring input 0 in
             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 c = new Cf_lexer.cursor 0
+        
+        let y s = p (Cf_parser.X.weave ~c (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 (Cf_seq.first z))
+            | Some ((v0, v1, v2), _) ->
+                failwith (Printf.sprintf "%02u, '%c', %02u" v0 v1 v2)
+            | _ ->
+                failwith "No match!"
+    end
 
-    let test () = L1.test1 (); L1.test2 ()
+    let test () =
+        let lexer =
+            Cf_lexer.create begin
+                (!*(!:'a' $| !:'b')) $& !$"abb" $^ (fun x -> x)
+            end
+        in
+        L1.test1 lexer;
+        L1.test2 lexer;
+        L2.test ()
 end
 
 module T7 = struct
         let i = (i :> ('a, int, float) rx) in
         let o = (o :> ('b, int, float) tx) in
         let rec loop () =
-            guard [
+            guard begin
                 i#get begin fun (`I n) ->
                     load >>= fun state ->
                     store (succ state) >>= fun () ->
                     o#put (`O oval) >>= fun () ->
                     loop ()
                 end
-            ]
+            end
         in
         loop ()
     
     let render osnk =
         let osnk = (osnk :> ('a, int, float) rx) in
         let rec loop () =
-            guard [
+            guard begin
                 osnk#get begin fun (`O n) ->
                     write n >>= loop
                 end
-            ]
+            end
         in
         loop ()
     
     open Cf_flow.Op
     
     let test () =
-        let n = 1000 in
+        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
 end
 
 module T11 = struct
+    let len = 100
+
     let test () =
         try
             let bind =
             let bind = listen#getsockname in
             let active = new Cf_tcp4_socket.initiator bind in
             active#connect;
-            let a =
-                new Cf_tcp4_socket.endpoint (let a, _ = listen#accept in a)
-            in
+            let a, _ = listen#accept in
+            let a = new Cf_tcp4_socket.endpoint a in
             let b = new Cf_tcp4_socket.endpoint (active#socket) in
+            let laddr = a#getpeername and raddr = b#getsockname in
+            let lhost, lport = laddr in
+            let rhost, rport = raddr in
+            if lhost <> rhost then
+                failwith "T11 error: host a#getpeername <> b#getsockname";
+            if lport <> rport then
+                failwith "T11 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 "T11 error: host a#getsockname <> b#getpeername";
+            if lport <> rport then
+                failwith "T11 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 "T11 error: tx incomplete!";
+            let n = b#recv rx 0 len in
+            if n <> len then failwith "T11 error: rx incomplete!";
+            if tx <> rx then failwith "T11 error: tx <> rx!";
             a#close;
-            b#close
+            b#close;
+            listen#close
         with
         | Unix.Unix_error (e, fn, _) ->
             failwith (Printf.sprintf "T11 error: %s in %s.\n"
 end
 
 module T12 = struct
+    let len = 100
+
     let test () =
         try
             let bind =
             let bind = listen#getsockname in
             let active = new Cf_tcp6_socket.initiator bind in
             active#connect;
-            let a =
-                new Cf_tcp6_socket.endpoint (let a, _ = listen#accept in a)
-            in
+            let a, _ = listen#accept in
+            let a = new Cf_tcp6_socket.endpoint a in
             let b = new Cf_tcp6_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 "T12 error: host a#getpeername <> b#getsockname";
+            if lport <> rport then
+                failwith "T12 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 "T12 error: host a#getsockname <> b#getpeername";
+            if lport <> rport then
+                failwith "T12 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 "T12 error: tx incomplete!";
+            let n = b#recv rx 0 len in
+            if n <> len then failwith "T12 error: rx incomplete!";
+            if tx <> rx then failwith "T12 error: tx <> rx!";
             a#close;
-            b#close
+            b#close;
+            listen#close
         with
         | Unix.Unix_error (e, fn, _) ->
-            failwith (Printf.sprintf "T11 error: %s in %s.\n"
+            failwith (Printf.sprintf "T12 error: %s in %s.\n"
                 (Unix.error_message e) fn)
 end
 
             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 resolve resolve_list;
+            List.iter unresolved unresolved_list
     end
 
     let test () =
         ignore (Unix.sigprocmask Unix.SIG_SETMASK save)
 end
 
+module T16 = 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
+
 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; T14.test; T15.test
+        T11.test; T12.test; T13.test; T14.test; T15.test;
+        T16.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) ->