Commits

Jacques-Pascal Deplaix  committed f684fd2 Merge with conflicts

Merge branch 'type-system'

Conflicts:
LLVM.ml
LLVM.mli
main.ml

  • Participants
  • Parent commits 5b2dd11, 05f1003

Comments (0)

Files changed (6)

   | `Dllexport
   ]
 
-type data_type =
-  | Int of int
-  | Array of int * data_type
-  | Pointer of data_type
-  | Pointer_function of data_type array * data_type
-
 type address =
   | Addrspace of int
   | Unnamed_addr
 type instr =
   | Ret
 
-type context_module =
+type 'a context_module =
   | Global of
     (string * thread_local option *
     address * link_type option * bool *
-    data_type * string option * int option)
+    'a LLVM_types.t * string option * int option)
   | Declaration of
-    (data_type * string * data_type array *
+    ('a LLVM_types.t * string * 'a LLVM_types.t array *
     [`External | `Dllimport | `Extern_weak ] option)
   | Definition of
-    ((data_type * string * data_type array) * instr list)
+    (('a LLVM_types.t * string * 'a LLVM_types.t array) * instr list)
 
 let string_of_link_type = function
   | `Private                -> "private"
   | `Dllimport              -> "dllimport"
   | `Dllexport              -> "dllexport"
 
-let rec string_of_data_type ?f:(name = "") data =
-  let rec aux acc arr = function
-    | 0 -> acc
-    | n -> aux (acc ^ ", " ^ (string_of_data_type arr.(n))) arr (n - 1)
-  in match data with
-  | Int i                   -> "i" ^ (string_of_int i)
-  | Pointer t               -> string_of_data_type t ^ "*"
-  | Array (i, t) ->
-    "[" ^ (string_of_int i) ^ " x " ^ (string_of_data_type t) ^ "]"
-  | Pointer_function (a, t) ->
-    (string_of_data_type t) ^ " @" ^ name ^ "("
-    ^ (aux (if Array.length a > 0 then (string_of_data_type a.(0)) else "") a
-      (Array.length a - 1))
-    ^ ") *"
-
 let string_of_instr = function
   | Ret                     -> "\tret"
 
   in let string_constant = match constant with
     | true                  -> " constant"
     | false                 -> ""
-  in let string_data_type = " " ^ (string_of_data_type data_type)
+  in let string_data_type = " " ^ (LLVM_types.to_string data_type)
   in let string_section = match section with
     | None                  -> ""
     | Some a                -> ", section \"" ^ a ^ "\""
   (type_return, id, type_arguments, link_type) =
   let rec aux acc arr n =
     if n <= 0 then acc
-    else aux (acc ^ ", " ^ (string_of_data_type arr.(n))) arr (n - 1)
-  in let string_type_return = (string_of_data_type type_return)
+    else aux (acc ^ ", " ^ (LLVM_types.to_string arr.(n))) arr (n - 1)
+  in let string_type_return = (LLVM_types.to_string type_return)
   in let string_type_arguments =
     aux (if Array.length type_arguments > 0
-      then (string_of_data_type type_arguments.(0))
+      then (LLVM_types.to_string type_arguments.(0))
       else "") type_arguments (Array.length type_arguments - 1)
   in let string_link_type = match link_type with
     | None                  -> ""
   ((type_return, id, type_arguments), instr_list) =
   let rec aux acc arr n =
     if n <= 0 then acc
-    else aux (acc ^ ", " ^ (string_of_data_type arr.(n))) arr (n - 1)
-  in let string_type_return = (string_of_data_type type_return)
+    else aux (acc ^ ", " ^ (LLVM_types.to_string arr.(n))) arr (n - 1)
+  in let string_type_return = (LLVM_types.to_string type_return)
   in let string_type_arguments =
     aux (if Array.length type_arguments > 0
-      then (string_of_data_type type_arguments.(0))
+      then (LLVM_types.to_string type_arguments.(0))
       else "") type_arguments (Array.length type_arguments - 1)
   in let string_instr_list =
     List.fold_left (fun a x -> a ^ (string_of_instr x) ^ "\n") "" instr_list
   | `Dllexport
   ]
 
-type data_type =
-  | Int of int
-  | Array of int * data_type
-  | Pointer of data_type
-  | Pointer_function of data_type array * data_type
-
 type address =
   | Addrspace of int
   | Unnamed_addr
 type instr =
   | Ret
 
-type context_module =
+type 'a context_module =
   | Global of
     (string * thread_local option *
     address * link_type option * bool *
-    data_type * string option * int option)
+    'a LLVM_types.t * string option * int option)
   | Declaration of
-    (data_type * string * data_type array *
+    ('a LLVM_types.t * string * 'a LLVM_types.t array *
     [`External | `Dllimport | `Extern_weak ] option)
   | Definition of
-    ((data_type * string * data_type array) * instr list)
+    (('a LLVM_types.t * string * 'a LLVM_types.t array) * instr list)
 
 (*
  *  Global:
   ?constant: bool ->
   ?section: string option ->
   ?alignment: int option ->
-  string -> data_type -> context_module
+  string -> 'a LLVM_types.t -> 'a context_module
 
 val new_declaration:
   ?link_type: [< `External | `Dllimport | `Extern_weak ] option ->
-  data_type -> string -> data_type array -> context_module
+  'a LLVM_types.t -> string -> 'a LLVM_types.t array -> 'a context_module
 
 val new_definition:
-  data_type -> string -> data_type array -> instr list -> context_module
+  'a LLVM_types.t -> string -> 'a LLVM_types.t array -> instr list -> 'a context_module
 
-val print_context_module: context_module -> unit
+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

File LLVM_types.ml

+type 'a t = {data : 'a}
+
+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)]
+
+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)}
+
+let rec to_string data =
+  let rec aux acc arr = function
+    | 0 -> acc
+    | n -> aux (acc ^ ", " ^ to_string arr.(n).data) arr (pred n)
+  in
+  match data with
+    | `Int (i, _) -> "i" ^ string_of_int i
+    | `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

File LLVM_types.mli

+type 'a t
+
+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)]
+
+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
+
+val to_string :
+  ([< llvm_int
+   | 'a llvm_array
+   | 'a llvm_pointer
+   | ('a, 'a) llvm_function_pointer
+   ] as 'a) t ->
+  string
+# Just for testing
+all:
+	ocamlc LLVM_types.mli LLVM_types.ml LLVM.mli LLVM.ml main.ml
 let () =
   LLVM.print_context_module
     (LLVM.new_global
-      ~link_type:(Some `Internal)
-      ~constant:true
-      "msg" (LLVM.Array (13, LLVM.Int 8)));
+       ~link_type:(Some `Internal)
+       ~constant:true
+       "msg"
+       (LLVM_types.array 13 (LLVM_types.int 8 None))
+    );
   LLVM.print_context_module
     (LLVM.new_declaration
-      (LLVM.Int 32) "puts" [| LLVM.Pointer (LLVM.Int 8); LLVM.Int 32 |]
-      ~link_type: (Some `External));
+       (LLVM_types.int 32 None)
+       "puts"
+       [| LLVM_types.pointer (LLVM_types.int 8 None) None; LLVM_types.int 32 None |]
+      ~link_type:(Some `External)
+    );
   LLVM.print_context_module
     (LLVM.new_definition
-      (LLVM.Int 32) "main" [||] [LLVM.Ret])
+      (LLVM_types.int 32 None) "main" [||] [LLVM.Ret])