Add support for 'const' and 'volatile'

examples/fts/stub-generation/bindings/fts_bindings.ml

@@ -19,7 +19,7 @@ struct
      int ( *compar)(const FTSENT **, const FTSENT ** ));
   *)
   let _fts_open = foreign "fts_open"
-    (ptr (ptr char) @-> int @-> compar_typ_opt @-> returning (ptr fts))
+    (ptr (const (ptr char)) @-> int @-> compar_typ_opt @-> returning (ptr fts))
 
   (* FTSENT *fts_read(FTS *ftsp); *)
   let _fts_read = foreign "fts_read" (* ~check_errno:true *)

examples/fts/stub-generation/bindings/fts_types.ml

@@ -107,6 +107,7 @@ struct
 
   type t = ftsent structure ptr
   let t = ptr ftsent
+  let const_t = ptr (const ftsent)
 
   let info : t -> fts_info
     = fun t -> fts_info_of_int (UShort.to_int (getf !@t fts_info))
@@ -155,10 +156,12 @@ struct
 
   type compar_typ = t ptr -> t ptr -> int
   let compar_typ : compar_typ typ =
-    Foreign.funptr (ptr FTSENT.t @-> ptr FTSENT.t @-> returning int)
+    Foreign.funptr
+      (ptr FTSENT.const_t @-> ptr FTSENT.const_t @-> returning int)
   type compar_typ_opt = compar_typ option
   let compar_typ_opt : compar_typ_opt typ =
-    Foreign.funptr_opt (ptr FTSENT.t @-> ptr FTSENT.t @-> returning int)
+    Foreign.funptr_opt
+      (ptr FTSENT.const_t @-> ptr FTSENT.const_t @-> returning int)
 
   type fts
   let struct_fts : fts structure typ = structure "FTS"

src/cstubs/cstubs_analysis.ml

@@ -106,6 +106,7 @@ let rec allocation : type a. a typ -> a allocation = function
    | `Alloc a -> `Alloc (Alloc_view (v, a))
    | `Noalloc na -> `Noalloc (Noalloc_view (v, na))
    end
+ | Qualified (_, ty) -> allocation ty
  | Array _ -> `Alloc Alloc_array
  | Bigarray ba -> `Alloc (Alloc_bigarray ba)
  | OCaml _ -> `Alloc Alloc_pointer

src/cstubs/cstubs_generate_c.ml

@@ -147,6 +147,7 @@ struct
             `Deref (`Cast (Ty (ptr orig), y)))
     | Abstract _ -> report_unpassable "values of abstract type"
     | View { ty } -> prj ty ~orig x
+    | Qualified (_, ty) -> prj ty ~orig x
     | Array _ -> report_unpassable "arrays"
     | Bigarray _ -> report_unpassable "bigarrays"
     | OCaml String -> Some (string_to_ptr x)
@@ -165,6 +166,7 @@ struct
     | Union u -> `App (copy_bytes, [`Addr (x :> cvar); `Int (Signed.SInt.of_int (sizeof ty))])
     | Abstract _ -> report_unpassable "values of abstract type"
     | View { ty } -> inj ty x
+    | Qualified (_, ty) -> inj ty x
     | Array _ -> report_unpassable "arrays"
     | Bigarray _ -> report_unpassable "bigarrays"
     | OCaml _ -> report_unpassable "ocaml references as return values"
@@ -364,6 +366,7 @@ struct
     | Pointer _ -> Generate_C.of_fatptr x
     | Funptr _ -> Generate_C.of_fatptr x
     | View { ty } -> prj ty ~orig x
+    | Qualified (_, ty) -> prj ty ~orig x
     | t -> unsupported t
 
   let prj ty x = prj ty ~orig:ty x

src/cstubs/cstubs_generate_ml.ml

@@ -241,6 +241,7 @@ let rec ml_typ_of_return_typ : type a. a typ -> ml_type =
   | Pointer _   -> voidp
   | Funptr _    -> voidp
   | View { ty } -> ml_typ_of_return_typ ty
+  | Qualified (_, ty) -> ml_typ_of_return_typ ty
   | Array _    as a -> internal_error
     "Unexpected array type in the return type: %s" (Ctypes.string_of_typ a)
   | Bigarray _ as a -> internal_error
@@ -261,6 +262,7 @@ let rec ml_typ_of_arg_typ : type a. a typ -> ml_type = function
   | Union _     -> fatptr
   | Abstract _  -> fatptr
   | View { ty } -> ml_typ_of_arg_typ ty
+  | Qualified (_, ty) -> ml_typ_of_arg_typ ty
   | Array _    as a -> internal_error
     "Unexpected array in an argument type: %s" (Ctypes.string_of_typ a)
   | Bigarray _ as a -> internal_error
@@ -430,6 +432,23 @@ let rec pattern_and_exp_of_typ : type a. concurrency:concurrency_policy -> errno
                    path_of_string "read", `Var x], `Etc)] in
       (pat, Some (map_result ~concurrency ~errno (`Appl x) e), binds)
     end
+  | Qualified (_, ty) ->
+    begin match pol  with
+    | In ->
+      let x = fresh_var () in
+      let y = fresh_var () in
+      let e = `Appl (`Ident (path_of_string x), e) in
+      let (p, None, binds), e | (p, Some e, binds), _ =
+        pattern_and_exp_of_typ ~concurrency ~errno ty e pol binds, e in
+      let pat = static_con "Qualified" [`Underscore; `Var x] in
+      (pat, Some (`Ident (Ctypes_path.path_of_string y)), (`Var y, e) :: binds)
+    | Out ->
+      let (p, None, binds), e | (p, Some e, binds), _ =
+        pattern_and_exp_of_typ ~concurrency ~errno ty e pol binds, e in
+      let x = fresh_var () in
+      let pat = static_con "Qualified" [`Underscore; `Var x] in
+      (pat, Some (map_result ~concurrency ~errno (`Appl x) e), binds)
+    end
   | OCaml ty ->
     begin match pol, ty with
     | In, String -> (static_con "OCaml" [static_con "String" []], None, binds)
@@ -469,6 +488,8 @@ let rec pattern_of_typ : type a. a typ -> ml_pat = function
   | View { ty } ->
     static_con "View"
       [`Record ([path_of_string "CI.ty", pattern_of_typ ty], `Etc)]
+  | Qualified (_, ty) ->
+    static_con "Qualified" [`Underscore; pattern_of_typ ty]
   | Array (_, _) ->
      static_con "Array" [`Underscore; `Underscore]
   | Bigarray _ ->

src/ctypes-foreign/ctypes_ffi.ml

@@ -69,6 +69,7 @@ struct
     | Union _                             -> report_unpassable "unions"
     | Struct ({ spec = Complete _ } as s) -> struct_arg_type s
     | View { ty }                         -> arg_type ty
+    | Qualified (_, ty)                   -> arg_type ty
     | Array _                             -> report_unpassable "arrays"
     | Bigarray _                          -> report_unpassable "bigarrays"
     | Abstract _                          -> (report_unpassable

src/ctypes/cstubs_internals.mli

@@ -37,6 +37,7 @@ type 'a typ = 'a Ctypes_static.typ =
   | Union           : 'a Ctypes_static.union_type      -> 'a Ctypes_static.union typ
   | Abstract        : Ctypes_static.abstract_type      -> 'a Ctypes_static.abstract typ
   | View            : ('a, 'b) view             -> 'a typ
+  | Qualified       : Ctypes_static.qualifier * 'a typ -> 'a typ
   | Array           : 'a typ * int              -> 'a Ctypes_static.carray typ
   | Bigarray        : (_, 'a, _) Ctypes_bigarray.t -> 'a typ
   | OCaml           : 'a ocaml_type             -> 'a ocaml typ

src/ctypes/ctypes.mli

@@ -118,6 +118,16 @@ include Ctypes_types.TYPE
  with type 'a typ = 'a Ctypes_static.typ
   and type ('a, 's) field := ('a, 's) field
 
+(** {3 Qualified types} *)
+
+val const : 'a typ -> 'a typ
+(** [const t] const-qualifies the type [t].  At present the only
+    effect is that the type is marked 'const' in generated code. *)
+
+val volatile : 'a typ -> 'a typ
+(** [volatile t] volatile-qualifies the type [t].  At present the only
+    effect is that the type is marked 'volatile' in generated code. *)
+
 (** {3 Operations on types} *)
 
 val sizeof : 'a typ -> int

src/ctypes/ctypes_memory.ml

@@ -38,6 +38,7 @@ let rec build : type a b. a typ -> (_, b typ) Fat.t -> a
     | View { read; ty } ->
       let buildty = build ty in
       (fun buf -> read (buildty buf))
+    | Qualified (_, ty) -> build ty
     | OCaml _ -> (fun buf -> assert false)
     (* The following cases should never happen; non-struct aggregate
        types are excluded during type construction. *)
@@ -76,6 +77,7 @@ let rec write : type a b. a typ -> a -> (_, b) Fat.t -> unit
     | View { write = w; ty } ->
       let writety = write ty in
       (fun v -> writety (w v))
+    | Qualified (_, ty) -> write ty
     | OCaml _ -> raise IncompleteType
 
 let null : unit ptr = CPointer (Fat.make ~managed:None ~reftyp:Void Raw.null)

src/ctypes/ctypes_static.ml

@@ -34,6 +34,8 @@ type _ ocaml_type =
 | Bytes      : bytes ocaml_type
 | FloatArray : float array ocaml_type
 
+type qualifier = Const | Volatile
+
 type _ typ =
     Void            :                       unit typ
   | Primitive       : 'a Ctypes_primitive_types.prim -> 'a typ
@@ -43,6 +45,7 @@ type _ typ =
   | Union           : 'a union_type      -> 'a union typ
   | Abstract        : abstract_type      -> 'a abstract typ
   | View            : ('a, 'b) view      -> 'a typ
+  | Qualified       : qualifier * 'a typ -> 'a typ
   | Array           : 'a typ * int       -> 'a carray typ
   | Bigarray        : (_, 'a, _) Ctypes_bigarray.t
                                          -> 'a typ
@@ -136,6 +139,7 @@ let rec sizeof : type a. a typ -> int = function
   | Funptr _                       -> Ctypes_primitives.pointer_size
   | OCaml _                        -> raise IncompleteType
   | View { ty }                    -> sizeof ty
+  | Qualified (_, ty)              -> sizeof ty
 
 let rec alignment : type a. a typ -> int = function
     Void                             -> raise IncompleteType
@@ -152,6 +156,7 @@ let rec alignment : type a. a typ -> int = function
   | Funptr _                         -> Ctypes_primitives.pointer_alignment
   | OCaml _                          -> raise IncompleteType
   | View { ty }                      -> alignment ty
+  | Qualified (_, ty)                -> alignment ty
 
 let rec passable : type a. a typ -> bool = function
     Void                           -> true
@@ -167,22 +172,24 @@ let rec passable : type a. a typ -> bool = function
   | Abstract _                     -> false
   | OCaml _                        -> true
   | View { ty }                    -> passable ty
+  | Qualified (_, ty)              -> passable ty
 
 (* Whether a value resides in OCaml-managed memory.
    Values that reside in OCaml memory cannot be accessed
    when the runtime lock is not held. *)
 let rec ocaml_value : type a. a typ -> bool = function
-    Void        -> false
-  | Primitive _ -> false
-  | Struct _    -> false
-  | Union _     -> false
-  | Array _     -> false
-  | Bigarray _  -> false
-  | Pointer _   -> false
-  | Funptr _    -> false
-  | Abstract _  -> false
-  | OCaml _     -> true
-  | View { ty } -> ocaml_value ty
+    Void              -> false
+  | Primitive _       -> false
+  | Struct _          -> false
+  | Union _           -> false
+  | Array _           -> false
+  | Bigarray _        -> false
+  | Pointer _         -> false
+  | Funptr _          -> false
+  | Abstract _        -> false
+  | OCaml _           -> true
+  | View { ty }       -> ocaml_value ty
+  | Qualified (_, ty) -> ocaml_value ty
 
 let rec has_ocaml_argument : type a. a fn -> bool = function
     Returns _ -> false
@@ -274,6 +281,16 @@ let offsetof { foffset } = foffset
 let field_type { ftype } = ftype
 let field_name { fname } = fname
 
+let rec const : type a. a typ -> a typ = function
+  | Qualified (Const, _) as ty -> ty
+  | Qualified (Volatile, ty) -> Qualified (Volatile, const ty)
+  | ty -> Qualified (Const, ty)
+
+let rec volatile : type a. a typ -> a typ = function
+  | Qualified (Volatile, _) as ty -> ty
+  | Qualified (Const, ty) -> Qualified (Const, volatile ty)
+  | ty -> Qualified (Volatile, ty)
+
 (* This corresponds to the enum in ctypes_primitives.h *)
 type arithmetic =
     Int8

src/ctypes/ctypes_static.mli

@@ -26,6 +26,8 @@ type 'a structspec =
     Incomplete of incomplete_size
   | Complete of structured_spec
 
+type qualifier = Const | Volatile
+
 type _ typ =
     Void            :                       unit typ
   | Primitive       : 'a Ctypes_primitive_types.prim -> 'a typ
@@ -35,6 +37,7 @@ type _ typ =
   | Union           : 'a union_type      -> 'a union typ
   | Abstract        : abstract_type      -> 'a abstract typ
   | View            : ('a, 'b) view      -> 'a typ
+  | Qualified       : qualifier * 'a typ -> 'a typ
   | Array           : 'a typ * int       -> 'a carray typ
   | Bigarray        : (_, 'a, _) Ctypes_bigarray.t
                                          -> 'a typ
@@ -180,6 +183,8 @@ val union : string -> 'a union typ
 val offsetof : ('a, 'b) field -> int
 val field_type : ('a, 'b) field -> 'a typ
 val field_name : ('a, 'b) field -> string
+val const : 'a typ -> 'a typ
+val volatile : 'a typ -> 'a typ
 
 exception IncompleteType
 exception ModifyingSealedType of string

src/ctypes/ctypes_type_printing.ml

@@ -9,75 +9,77 @@
 
 open Ctypes_static
 
-(* See type_printing.mli for the documentation of [format context]. *)
+(* See ctypes_type_printing.mli for the documentation of [format_context]. *)
 type format_context = [ `toplevel | `array | `nonarray ]
 
+let format_qualifier : Format.formatter -> qualifier -> unit =
+  fun fmt q ->
+  match q with
+  | Const -> Format.fprintf fmt "const"
+  | Volatile -> Format.fprintf fmt "volatile"
+
 let rec format_typ' : type a. a typ ->
   (format_context -> Format.formatter -> unit) ->
   (format_context -> Format.formatter -> unit) =
   let fprintf = Format.fprintf in
-  fun t k context fmt -> match t with
-    | Void ->
+  fun t k ctxt fmt -> match t, ctxt with
+    | Void, _ ->
       fprintf fmt "void%t" (k `nonarray)
-    | Primitive p ->
+    | Primitive p, _ ->
       let name = Ctypes_primitives.name p in
       fprintf fmt "%s%t" name (k `nonarray)
-    | View { format_typ = Some format } ->
+    | View { format_typ = Some format }, _ ->
       format (k `nonarray) fmt
-    | View { ty } ->
+    | View { ty }, context ->
       format_typ' ty k context fmt
-    | Abstract { aname } ->
+    | Qualified (q, ty), ctxt ->
+       format_typ' ty 
+         (fun context fmt ->
+           fprintf fmt "@ %a%t" format_qualifier q (k context)) ctxt fmt
+    | Abstract { aname }, _ ->
       fprintf fmt "%s%t" aname (k `nonarray)
-    | Struct { tag = "" ; fields } ->
+    | Struct { tag = "" ; fields }, _ ->
       fprintf fmt "struct {@;<1 2>@[";
       format_fields fields fmt;
       fprintf fmt "@]@;}%t" (k `nonarray)
-    | Struct { tag ; spec; fields } ->
-      begin match spec, context with
-        | Complete _, `toplevel ->
-          begin
-            fprintf fmt "struct %s {@;<1 2>@[" tag;
-            format_fields fields fmt;
-            fprintf fmt "@]@;}%t" (k `nonarray)
-          end
-        | _ -> fprintf fmt "struct %s%t" tag (k `nonarray)
-      end
-    | Union { utag = ""; ufields } ->
+    | Struct { tag ; spec = Complete _; fields }, `toplevel ->
+       fprintf fmt "struct %s {@;<1 2>@[" tag;
+       format_fields fields fmt;
+       fprintf fmt "@]@;}%t" (k `nonarray)
+    | Struct { tag ; _ }, _ ->
+       fprintf fmt "struct %s%t" tag (k `nonarray)
+    | Union { utag = ""; ufields }, _ ->
       fprintf fmt "union {@;<1 2>@[";
       format_fields ufields fmt;
       fprintf fmt "@]@;}%t" (k `nonarray)
-    | Union { utag; uspec; ufields } ->
-      begin match uspec, context with
-        | Some _, `toplevel ->
-          begin
+    | Union { utag; uspec = Some _; ufields }, `toplevel ->
             fprintf fmt "union %s {@;<1 2>@[" utag;
             format_fields ufields fmt;
             fprintf fmt "@]@;}%t" (k `nonarray)
-          end
-        | _ -> fprintf fmt "union %s%t" utag (k `nonarray)
-      end
-    | Pointer ty ->
+    | Union { utag; _ }, context ->
+       fprintf fmt "union %s%t" utag (k `nonarray)
+    | Pointer ty, _ ->
       format_typ' ty
         (fun context fmt ->
           match context with
             | `array -> fprintf fmt "(*%t)" (k `nonarray)
             | _      -> fprintf fmt "*%t" (k `nonarray))
         `nonarray fmt
-    | Funptr fn ->
+    | Funptr fn, _ ->
       format_fn' fn
         (fun fmt -> Format.fprintf fmt "(*%t)" (k `nonarray)) fmt
-    | Array (ty, n) ->
+    | Array (ty, n), _ ->
       format_typ' ty (fun _ fmt -> fprintf fmt "%t[%d]" (k `array) n) `nonarray
         fmt
-    | Bigarray ba ->
+    | Bigarray ba, _ ->
       let elem = Ctypes_bigarray.element_type ba
       and dims = Ctypes_bigarray.dimensions ba in
       let name = Ctypes_primitives.name elem in
       fprintf fmt "%s%t%t" name (k `array)
         (fun fmt -> (Array.iter (Format.fprintf fmt "[%d]") dims))
-    | OCaml String -> format_typ' (ptr char) k context fmt
-    | OCaml Bytes -> format_typ' (ptr uchar) k context fmt
-    | OCaml FloatArray -> format_typ' (ptr double) k context fmt
+    | OCaml String, context -> format_typ' (ptr char) k context fmt
+    | OCaml Bytes, context -> format_typ' (ptr uchar) k context fmt
+    | OCaml FloatArray, context -> format_typ' (ptr double) k context fmt
 
 and format_fields : type a. a boxed_field list -> Format.formatter -> unit =
   fun fields fmt ->

src/ctypes/ctypes_types.mli

@@ -383,4 +383,6 @@ sig
   val static_funptr : 'a fn -> 'a Ctypes_static.static_funptr typ
   (** Construct a function pointer type from an existing function type
       (called the {i reference type}).  *)
+
+  val const : 'a typ -> 'a typ
 end

src/ctypes/ctypes_value_printing.ml

@@ -29,6 +29,7 @@ let rec format : type a. a typ -> Format.formatter -> a -> unit
       | None -> format ty fmt (write v)
       | Some f -> f fmt v
     end
+  | Qualified (_, ty) -> format ty fmt v
 and format_structured : type a b. Format.formatter -> (a, b) structured -> unit
   = fun fmt ({structured = CPointer p} as s) ->
     let open Format in