Commits

Jacques-Pascal Deplaix  committed 3350538

Simulate types using GADT instead of polymorphic variants (1/2)

  • Participants
  • Parent commits f0e9a90

Comments (0)

Files changed (4)

File examples/hello.ml

        ~link_type:(Some `Internal)
        ~constant:true
        "msg"
-       (LLVM_types.array 13 (LLVM_types.int 8 None))
+       (LLVM_types.Array (13, LLVM_types.Int 8))
     );
   LLVM.print_context_module
     (LLVM.new_declaration
-       (LLVM_types.int 32 None)
+       (LLVM_types.Int 32)
        "puts"
-       [| LLVM_types.pointer (LLVM_types.int 8 None) None |]
+       [| (*LLVM_types.Pointer (LLVM_types.Int 8)*) |]
       ~link_type:(Some `External)
     );
   LLVM.print_context_module
     (LLVM.new_definition
-      (LLVM_types.int 32 None) "main" [||] [LLVM.Ret (LLVM_types.int 32
-      (Some (Big_int.big_int_of_int 0)))])
+      (LLVM_types.Int 32)
+      "main"
+      [||]
+      [LLVM.Ret (LLVM_types.Int 32 (*Some (Big_int.big_int_of_int 0)*))]
+    )

File src/LLVM.mli

 val new_definition:
   'a LLVM_types.t -> string -> 'a LLVM_types.t array -> 'a instr list -> 'a context_module
 
-val print_context_module:
-  ([< 'a LLVM_types.llvm_array
-   | ('a, 'a) LLVM_types.llvm_function_pointer
-   | LLVM_types.llvm_int
-   | 'a LLVM_types.llvm_pointer
-   ] as 'a) context_module ->
-  unit
+val print_context_module: 'a context_module -> unit

File src/LLVM_types.ml

-type 'a t = {data : 'a}
+type _ f =
+  | Ret : 'a t -> 'a t f
+  | App : 'a t * 'b f -> ('a * 'b) f
 
-type llvm_int = [`Int of (int * Big_int.big_int option)]
-type 'a llvm_array = [`Array of (int * 'a t)]
-type 'a llvm_pointer = [`Pointer of ('a t * int option)]
-type ('a, 'b) llvm_function_pointer = [`Function_pointer of ('a t array * 'b t * int option)]
+and _ t =
+  | Int : int -> int t
+  | Array : int * 'a t -> 'a t array t
+  | Pointer : 'a t -> 'a t t
+  | FunctionPointer : 'a f -> 'a f t
 
-let int i x = {data = `Int (i, x)}
-let array i x = {data = `Array (i, x)}
-let pointer t x = {data = `Pointer (t, x)}
-let function_pointer params return_type x = {data = `Function_pointer (params, return_type, x)}
+type 'a value = 'a t * 'a
 
-let rec to_string data =
-  let rec aux acc arr = function
-    | 0 -> acc
-    | n -> aux (acc ^ ", " ^ to_string arr.(n).data) arr (pred n)
+let rec to_string : type a. a t -> string = fun data ->
+  let rec aux : type a. string -> a f -> string = fun acc -> function
+    | Ret t -> to_string t ^ " @(" ^ acc ^ ") *"
+    | App (t, f) -> aux (acc ^ ", " ^ to_string t) f (* FALSE ! Also before *)
   in
   match data with
-    | `Int (i, a) -> "i" ^ string_of_int i ^
-    (match a with | Some a -> " " ^ Big_int.string_of_big_int a | None -> "")
-    | `Pointer (t, _) -> to_string t.data ^ "*"
-    | `Array (i, t) ->
-        "[" ^ string_of_int i ^ " x " ^ to_string t.data ^ "]"
-    | `Function_pointer (a, t, _) ->
-        to_string t.data ^ " @("
-        ^ aux
-          (if Array.length a > 0 then to_string a.(0).data else "")
-          a
-          (Array.length a - 1)
-        ^ ") *"
-
-let to_string data = to_string data.data
+    | Int i -> "i" ^ string_of_int i
+    | Array (i, t) ->
+        "[" ^ string_of_int i ^ " x " ^ to_string t ^ "]"
+    | Pointer t -> to_string t ^ "*"
+    | FunctionPointer f -> aux "" f

File src/LLVM_types.mli

-type 'a t
+type _ f =
+  | Ret : 'a t -> 'a t f
+  | App : 'a t * 'b f -> ('a * 'b) f
 
-type llvm_int = [`Int of (int * Big_int.big_int option)]
-type 'a llvm_array = [`Array of (int * 'a t)]
-type 'a llvm_pointer = [`Pointer of ('a t * int option)]
-type ('a, 'b) llvm_function_pointer = [`Function_pointer of ('a t array * 'b t * int option)]
+and _ t =
+  | Int : int -> int t
+  | Array : int * 'a t -> 'a t array t
+  | Pointer : 'a t -> 'a t t
+  | FunctionPointer : 'a f -> 'a f t
 
-val int : int -> Big_int.big_int option -> [> llvm_int ] t
-val array : int -> 'a t -> [> 'a llvm_array ] t
-val pointer : 'a t -> int option -> [> 'a llvm_pointer ] t
-val function_pointer : 'a t array -> 'b t -> int option -> [> ('a, 'b) llvm_function_pointer ] t
+type 'a value = 'a t * 'a
 
-val to_string :
-  ([< llvm_int
-   | 'a llvm_array
-   | 'a llvm_pointer
-   | ('a, 'a) llvm_function_pointer
-   ] as 'a) t ->
-  string
+val to_string : 'a t -> string