From 5f45999036960c88994d0318285ad63ca7ab4e7f Mon Sep 17 00:00:00 2001
From: Quentin Carbonneaux <quentin.carbonneaux@yale.edu>
Date: Sat, 19 Mar 2016 18:56:37 -0400
Subject: add code to generate types

---
 lisc/tools/abi.ml | 135 +++++++++++++++++++++++++++++++++++++++++++-----------
 1 file changed, 107 insertions(+), 28 deletions(-)

(limited to 'lisc/tools')

diff --git a/lisc/tools/abi.ml b/lisc/tools/abi.ml
index 0427454..0f58609 100644
--- a/lisc/tools/abi.ml
+++ b/lisc/tools/abi.ml
@@ -1,30 +1,109 @@
 (* fuzzer *)
 
-module R = Random
-
-let maxargs = 10
-let maxmems = 16
-
-type _ basety =
-  | Char: int basety
-  | Short: int basety
-  | Int: int basety
-  | Long: int basety
-  | Float: float basety
-  | Double: float basety
-
-type _ structy =
-  | Field: 'a basety * 'b structy -> ('a * 'b) structy
-  | Empty: unit structy
-
-type _ abity =
-  | Base: 'a basety -> 'a abity
-  | Struct: 'a structy -> 'a abity
-
-let _ =
-  let f = open_in "/dev/urandom" in
-  let s = Char.code (input_char f) in
-  let s = Char.code (input_char f) + (s lsl 8) in
-  R.init s;
-  Printf.printf "Seed: %d\n" s;
-  ()
+type _ bty =
+  | Char: int bty
+  | Short: int bty
+  | Int: int bty
+  | Long: int bty
+  | Float: float bty
+  | Double: float bty
+
+type _ sty =
+  | Field: 'a bty * 'b sty -> ('a * 'b) sty
+  | Empty: unit sty
+
+type _ aty =
+  | Base: 'a bty -> 'a aty
+  | Struct: 'a sty -> 'a aty
+
+type anyb = AB: _ bty -> anyb (* kinda boring... *)
+type anys = AS: _ sty -> anys
+type anya = AA: _ aty -> anya
+
+
+let btysize: type a. a bty -> int = function
+  | Char -> 1
+  | Short -> 2
+  | Int -> 4
+  | Long -> 8
+  | Float -> 4
+  | Double -> 8
+
+let btyalign = btysize
+
+
+(* Generate types and test vectors. *)
+module Gen = struct
+  module R = Random
+
+  let init = function
+    | None ->
+      let f = open_in "/dev/urandom" in
+      let seed =
+        Char.code (input_char f) lsl 8 +
+        Char.code (input_char f) in
+      close_in f;
+      R.init seed;
+      seed
+    | Some seed ->
+      R.init seed;
+      seed
+
+  let int sz =
+    let bound = 1 lsl (8 * min sz 3 - 1) in
+    let i = R.int bound in
+    if R.bool () then - i else i
+
+  let float () =
+    let f = R.float 1000. in
+    if R.bool () then -. f else f
+
+  let test: type a. a aty -> a =
+    let tb: type a. a bty -> a = function (* eh, dry... *)
+      | Float  -> float ()
+      | Double -> float ()
+      | Char   -> int (btysize Char)
+      | Short  -> int (btysize Short)
+      | Int    -> int (btysize Int)
+      | Long   -> int (btysize Long) in
+    let rec ts: type a. a sty -> a = function
+      | Field (b, s) -> (tb b, ts s)
+      | Empty -> () in
+    function
+    | Base b -> tb b
+    | Struct s -> ts s
+
+  let b () = (* uniform *)
+    match R.int 6 with
+    | 0 -> AB Char
+    | 1 -> AB Short
+    | 2 -> AB Int
+    | 3 -> AB Long
+    | 4 -> AB Float
+    | _ -> AB Double
+
+  let binn = 10   (* default parameters for binomial law of s *)
+  and binp = 0.5
+
+  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 a ?(n=binn) ?(pp=binp) ?(ps=0.2) () =
+    if R.float 1.0 > ps then
+      let AB bt = b () in
+      AA (Base bt)
+    else
+      let AS st = s ~n ~pp () in
+      AA (Struct st)
+
+end
+
+
+(* Code generation for C *)
+module OutC = struct
+  open Printf
+
+end
-- 
cgit 1.4.1