diff options
Diffstat (limited to 'lisc/tools')
| -rw-r--r-- | lisc/tools/abi.ml | 164 |
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; + () |