finish OutC, use uniform distributions

1 files changed, 131 insertions, 33 deletions

diff --git a/lisc/tools/abi.ml b/lisc/tools/abi.ml
index 61b5423..75caca0 100644
--- a/lisc/tools/abi.ml
+++ b/lisc/tools/abi.ml
@@ -63,7 +63,7 @@ module Gen = struct
     let f = R.float 1000. in
     if R.bool () then -. f else f
 
-  let test: type a. a aty -> a =
+  let testv: type a. a aty -> a =
     let tb: type a. a bty -> a = function (* eh, dry... *)
       | Float  -> float ()
       | Double -> float ()
@@ -87,24 +87,38 @@ module Gen = struct
     | 4 -> AB Float
     | _ -> AB Double
 
-  let binn = 8   (* default parameters for binomial law of s *)
-  and binp = 0.8
+  let smax = 4      (* max elements in structs *)
+  let structp = 0.3 (* odds of having a struct type *)
+  let amax = 8      (* max function arguments *)
 
-  let rec s ?(n=binn) ?(pp=binp) () = (* binomial law *)
-    if n = 0 || R.float 1.0 > pp then AS Empty else
-    let AB bt = b () in
-    let AS st = s ~n:(n-1) () in
-    AS (Field (bt, st))
+  let s () =
+    let rec f n =
+      if n = 0 then AS Empty else
+      let AB bt = b () in
+      let AS st = f (n-1) in
+      AS (Field (bt, st)) in
+    f (1 + R.int (smax-1))
 
-  let a ?(n=binn) ?(pp=binp) ?(ps=0.8) () =
-    if R.float 1.0 > ps then
+  let a () =
+    if R.float 1.0 > structp then
       let AB bt = b () in
       AA (Base bt)
     else
       let AB bt = b () in
-      let AS st = s ~n ~pp () in
+      let AS st = s () in
       AA (Struct (Field (bt, st)))
 
+  let test () =
+    let AA ty = a () in
+    let t = testv ty in
+    T (ty, t)
+
+  let tests () =
+    let rec f n =
+      if n = 0 then [] else
+      test () :: f (n-1) in
+    f (R.int amax)
+
 end
 
 module type OUT = sig
@@ -118,7 +132,7 @@ end
 module OutC = struct
   open Printf
 
-  let ctype oc name =
+  let ctypelong oc name =
     let cb: type a. a bty -> unit = function
       | Char   -> fprintf oc "char"
       | Short  -> fprintf oc "short"
@@ -136,25 +150,31 @@ module OutC = struct
     function
     | Base b ->
       cb b;
-      fprintf oc " %s" name;
     | Struct s ->
       fprintf oc "struct %s { " name;
       cs 1 s;
-      fprintf oc "} %s" name;
+      fprintf oc "}";
       ()
 
+  let ctype: type a. out_channel -> string -> a aty -> unit =
+    fun oc name -> function
+    | Struct _ -> fprintf oc "struct %s" name
+    | t -> ctypelong oc "" t
+
+  let base: type a. out_channel -> a bty * a -> unit =
+    fun oc -> function
+    | Char, i   -> fprintf oc "%d" i
+    | Short, i  -> fprintf oc "%d" i
+    | Int, i    -> fprintf oc "%d" i
+    | Long, i   -> fprintf oc "%d" i
+    | Float, f  -> fprintf oc "%ff" f
+    | Double, f -> fprintf oc "%f" f
+
   let init oc name (T (ty, t)) =
-    let initb: type a. a bty * a -> unit = function
-      | Char, i   -> fprintf oc "%d" i
-      | Short, i  -> fprintf oc "%d" i
-      | Int, i    -> fprintf oc "%d" i
-      | Long, i   -> fprintf oc "%d" i
-      | Float, f  -> fprintf oc "%ff" f
-      | Double, f -> fprintf oc "%f" f in
     let inits s =
       let rec f: type a. a sty * a -> unit = function
         | Field (b, s), (tb, ts) ->
-          initb (b, tb);
+          base oc (b, tb);
           fprintf oc ", ";
           f (s, ts)
         | Empty, () -> () in
@@ -162,9 +182,9 @@ module OutC = struct
       f s;
       fprintf oc "}"; in
     ctype oc name ty;
-    fprintf oc " = ";
+    fprintf oc " %s = " name;
     begin match (ty, t) with
-    | Base b, tb -> initb (b, tb)
+    | Base b, tb -> base oc (b, tb)
     | Struct s, ts -> inits (s, ts)
     end;
     fprintf oc ";\n";
@@ -180,28 +200,106 @@ module OutC = struct
     ; "#include <stdlib.h>"
     ; ""
     ; "static void"
-    ; "fail(int ret, int chk)"
+    ; "fail(char *chk)"
     ; "{"
-    ; "\tfprintf(stderr, \"fail: %s check number %d\\n\""
-    ; "\t\tret ? \"return\" : \"argument\", chk);"
+    ; "\tfprintf(stderr, \"fail: checking %s\\n\", chk);"
     ; "\tabort();"
     ; "}"
     ; ""
     ]
 
+  let typedef oc name = function
+    | T (Struct ts, _) ->
+      ctypelong oc name (Struct ts);
+      fprintf oc ";\n";
+    | _ -> ()
+
+  let check oc name =
+    let chkbase: type a. string -> a bty * a -> unit =
+      fun name t ->
+        fprintf oc "\tif (%s != " name;
+        base oc t;
+        fprintf oc ")\n\t\tfail(%S);\n" name; in
+    function
+    | T (Base b, tb) -> chkbase name (b, tb)
+    | T (Struct s, ts) ->
+      let rec f: type a. int -> a sty * a -> unit =
+        fun i -> function
+        | Field (b, s), (tb, ts) ->
+          chkbase (Printf.sprintf "%s.f%d" name i) (b, tb);
+          f (i+1) (s, ts);
+        | Empty, () -> () in
+      f 1 (s, ts)
+
+  let argname i = "arg" ^ string_of_int (i+1)
+
+  let proto oc (T (tret, _)) args =
+    ctype oc "ret" tret;
+    fprintf oc " f(";
+    let narg = List.length args in
+    List.iteri (fun i (T (targ, _)) ->
+      ctype oc (argname i) targ;
+      fprintf oc " %s" (argname i);
+      if i <> narg-1 then
+        fprintf oc ", ";
+    ) args;
+    fprintf oc ")";
+    ()
+
   let caller oc ret args =
+    let narg = List.length args in
     prelude oc;
-    fprintf oc "int\nmain()\n{";
+    typedef oc "ret" ret;
+    List.iteri (fun i arg ->
+      typedef oc (argname i) arg;
+    ) args;
+    proto oc ret args;
+    fprintf oc ";\n\nint main()\n{\n";
+    List.iteri (fun i arg ->
+      fprintf oc "\t";
+      init oc (argname i) arg;
+    ) args;
     fprintf oc "\t";
+    let T (tret, _) = ret in
+    ctype oc "ret" tret;
+    fprintf oc " ret;\n\n";
+    fprintf oc "\tret = f(";
+    List.iteri (fun i _ ->
+      fprintf oc "%s" (argname i);
+      if i <> narg-1 then
+        fprintf oc ", ";
+    ) args;
+    fprintf oc ");\n";
+    check oc "ret" ret;
+    fprintf oc "\n\treturn 0;\n}\n";
+    ()
+
+  let callee oc ret args =
+    prelude oc;
+    typedef oc "ret" ret;
+    List.iteri (fun i arg ->
+      typedef oc (argname i) arg;
+    ) args;
+    fprintf oc "\n";
+    proto oc ret args;
+    fprintf oc "\n{\n\t";
     init oc "ret" ret;
-    fprintf oc "}\n";
+    fprintf oc "\n";
+    List.iteri (fun i arg ->
+      check oc (argname i) arg;
+    ) args;
+    fprintf oc "\n\treturn ret;\n}\n";
     ()
 
 end
 
 
 let _ =
-  let _seed = Gen.init None in
-  let AA ty = Gen.a () in
-  let t = Gen.test ty in
-  OutC.caller stdout (T (ty, t)) []
+  let seed = Gen.init None in
+  let tret = Gen.test () in
+  let targs = Gen.tests () in
+  let oc = stdout in
+  OutC.comment oc (Printf.sprintf "seed %d" seed);
+  (* OutC.caller oc tret targs; *)
+  OutC.callee oc tret targs;
+  ()