(* c.ml -- Copyright (c) 2001 David Fox *)

(*
  The C module implements the run-time portion of the ocaml to C
  foreign function interface.  The major elements are external
  functions to return size and alignment information about the
  primitive types, and a variant type t representing four flavors of
  pointers.

  Type p is used to hold actual pointer values in the resulting
  interface.   When a Pointer type is passed the function receives a
  pointer to the first character of the argument string.  This is for
  data that is managed by the ML garbage collector.  When a PointerRef
  type is passed the string is interpreted as a four bytes pointer,
  so an additional dereferencing is performed.  This is for pointers
  that are returned by C functions.

  Example: passing Null has the same effect as passing
     PointerRef("\000\000\000\000")
*)

type uint = unit
type short = unit
type ushort = unit
type uint32 = unit
type uchar = unit
type double = unit
type longdouble = unit
type long = unit
type ulong = unit
type longlong = unit
type void = unit

type 'a p =
    Null			(* The null pointer *)
  | Pointer of string		(* Pointer to the beginning of an ML string *)
  | PointerOff of string * int	(* A pointer to somewhere in an ML string *)
  | PointerRef of string	(* String holds the bytes of the pointer *)

exception Size_mismatch of int * int * string 	(* Raised in ffipp output *)

external sizeof_bool: unit -> int = "c_sizeof_bool"
external sizeof_char: unit -> int = "c_sizeof_char"
external sizeof_short: unit -> int = "c_sizeof_short"
external sizeof_long: unit -> int = "c_sizeof_long"
external sizeof_long_long: unit -> int = "c_sizeof_long_long"
external sizeof_int: unit -> int = "c_sizeof_int"
external sizeof_float: unit -> int = "c_sizeof_float"
external sizeof_double: unit -> int = "c_sizeof_double"
external sizeof_long_double: unit -> int = "c_sizeof_long_double"
external sizeof_pointer: unit -> int = "c_sizeof_pointer"
external sizeof_enum: unit -> int = "c_sizeof_enum"
external sizeof_int32: unit -> int = "c_sizeof_int32"
external sizeof_int64: unit -> int = "c_sizeof_int64"

external align_bool: unit -> int = "c_align_bool"
external align_char: unit -> int = "c_align_char"
external align_short: unit -> int = "c_align_short"
external align_int: unit -> int = "c_align_int"
external align_float: unit -> int = "c_align_float"
external align_long: unit -> int = "c_align_long"
external align_double: unit -> int = "c_align_double"
external align_long_double: unit -> int = "c_align_long_double"
external align_pointer: unit -> int = "c_align_pointer"
external align_enum: unit -> int = "c_align_enum"
external align_int32: unit -> int = "c_align_int32"
external align_int64: unit -> int = "c_align_int64"

external make_null: unit -> unit p = "c_make_null"
external make_pointer: string -> unit p = "c_make_pointer"
external make_pointeroff : string -> int -> unit p = "c_make_pointeroff"
external make_pointerref : string -> unit p = "c_make_pointerref"

(* Return the referent of various types of pointers. *)

external int_ref : int p -> int = "c_int_ref"
external uint_ref : uint p -> int = "c_uint_ref"
external long_ref : long p -> int32 = "c_long_ref"
external ulong_ref : ulong p -> int32 = "c_ulong_ref"
external short_ref : short p -> int = "c_short_ref"
external ushort_ref : ushort p -> int = "c_ushort_ref"
external char_ref : char p -> char = "c_char_ref"
external byte_ref : char p -> char = "c_byte_ref"
external ubyte_ref : uchar p -> char = "c_ubyte_ref"
external float_ref : float p -> float = "c_float_ref"
external double_ref : double p -> float = "c_double_ref"
external long_double_ref : longdouble p -> float = "c_long_double_ref"
external bool_ref : bool p -> bool = "c_bool_ref"
external enum_ref : unit p -> int = "c_enum_ref"
external int32_ref : long p -> int32 = "c_int32_ref"
external uint32_ref : ulong p -> int64 = "c_uint32_ref"
external int64_ref : longlong p -> int64 = "c_int64_ref"
external string_ref : char p -> string = "c_string_ref"

external pointer_ref: string -> string = "c_pointer_ref"

(* Set the referent of various types of pointers. *)

external int_set : int p -> int -> unit = "c_int_set"
external uint_set : uint p -> int -> unit = "c_uint_set"
external long_set : long p -> int32 -> unit = "c_long_set"
external ulong_set : ulong p -> int32 -> unit = "c_ulong_set"
external short_set : short p -> int -> unit = "c_short_set"
external ushort_set : ushort p -> int -> unit = "c_ushort_set"
external char_set : char p -> char -> unit = "c_char_set"
external byte_set : char p -> char -> unit = "c_byte_set"
external ubyte_set : uchar p -> char -> unit = "c_ubyte_set"
external float_set : float p -> float -> unit = "c_float_set"
external double_set : double p -> float -> unit = "c_double_set"
external long_double_set : longdouble p -> float -> unit = "c_long_double_set"
external bool_set : bool p -> bool -> unit = "c_bool_set"
external enum_set : void p -> int -> unit = "c_enum_set"
external pointer_set : ('a p) p -> 'a p -> unit = "c_pointer_set"
external int32_set : long p -> int32 -> unit = "c_int32_set"
external uint32_set : ulong p -> int64 -> unit = "c_uint32_set"
external int64_set : longlong p -> int64 -> unit = "c_int64_set"

(* Primitive type allocators *)

let make_bool n = Pointer(String.create (n * (sizeof_bool ())))
let make_char n = Pointer(String.create (n * (sizeof_char ())))
let make_uchar = make_char
let make_short n = Pointer(String.create (n * (sizeof_short ())))
let make_ushort = make_short
let make_long n = Pointer(String.create (n * (sizeof_int32 ())))
let make_ulong n = Pointer(String.create (n * (sizeof_int32 ())))
let make_int n = Pointer(String.create (n * (sizeof_int ())))
let make_uint = make_int
let make_float n = Pointer(String.create (n * (sizeof_float ())))
let make_double n = Pointer(String.create (n * (sizeof_double ())))
let make_long_double n = Pointer(String.create (n * (sizeof_long_double ())))
let make_pointer n = Pointer(String.create (n * (sizeof_pointer ())))
let make_enum n = Pointer(String.create (n * (sizeof_enum ())))
let make_int32 n = Pointer(String.create (n * (sizeof_int32 ())))
let make_int64 n = Pointer(String.create (n * (sizeof_int64 ())))

(* Return a, but change its phantom type to that of b *)
let cast (a : 'a p) (b : 'b p) : 'b p =
  match a with
    Null -> Null
  | Pointer (string) -> Pointer (string)
  | PointerOff (string, off) -> PointerOff (string, off)
  | PointerRef (string) -> PointerRef (string)

(* external print_value: p -> p = "print_value" *)

exception Null_pointer

let is_null = function
    Null -> true
  | PointerRef "\000\000\000\000" -> true
  | _ -> false

(* Pointer arithmetic: add n bytes to the pointer's address.  Note
   that pointer arithmetic on `foreign' pointers is prohibited -- do
   it in C. *)

(* exception Cannot_add *)

(* Add an offset to a PointerRef (only) *)
external make_pointersum: string -> int -> string = "c_make_pointersum"

let pointer_sum a n =
  match a, n with
    Pointer (string), 0 -> Pointer (string)
  | Pointer (string), n -> PointerOff (string, n)
  | PointerOff (string, off), _ -> PointerOff (string, off+n)
  | PointerRef string, _ -> PointerRef (make_pointersum string n)
  | Null, _ -> raise Null_pointer

let pointer_ref a =
  match a with
    Pointer (string) -> PointerRef (string)
  | PointerOff (string, off) ->
      PointerRef (String.sub string off (sizeof_pointer ()))
  | PointerRef string -> PointerRef (pointer_ref string)
  | Null -> raise Null_pointer

let pointer_deref =
  function
      PointerRef string -> Pointer string
    | Pointer _
    | PointerOff _
    | Null  -> invalid_arg "pointer_deref"

external string_of_int32 : int32 -> string = "c_string_of_int32"

let make_int32_pointer n = Pointer (string_of_int32 n)