Merge pull request #782 from yallop/string-const-view

 Make string a view of ptr (const char), not ptr char

src/cstubs/cstubs_generate_ml.ml

@@ -432,23 +432,7 @@ 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
+  | Qualified (_, ty) -> pattern_and_exp_of_typ ~concurrency ~errno ty e pol binds
   | OCaml ty ->
     begin match pol, ty with
     | In, String -> (static_con "OCaml" [static_con "String" []], None, binds)

src/ctypes/ctypes_coerce.ml

@@ -106,6 +106,8 @@ let rec coercion : type a b. a typ -> b typ -> (a, b) coercion =
     | exception Uncoercible _ ->
        Coercion (fun (Static_funptr p) -> Static_funptr (Ctypes_ptr.Fat.coerce p b))
     end
+  | Qualified (_,l), r
+  | l, Qualified (_, r) -> coercion l r
   | l, r -> uncoercible l r
 
 and fn_coercion : type a b. a fn -> b fn -> (a, b) coercion =

src/ctypes/ctypes_std_views.ml

@@ -14,7 +14,7 @@ let char_ptr_of_string s =
                             ~managed:(Some (Obj.repr p)) ~reftyp:Ctypes_static.char
                      (Ctypes_memory_stubs.block_address p))
 
-let string = Ctypes_static.(view (ptr char))
+let string = Ctypes_static.(view (ptr (const char)))
   ~read:string_of_char_ptr ~write:char_ptr_of_string
 
 let read_nullable t reftyp =

tests/clib/test_functions.c

@@ -236,7 +236,7 @@ struct animal_methods {
   char *(*identify)(struct animal *);
 };
 
-int check_name(struct animal *a, char *name)
+int check_name(struct animal *a, const char *name)
 {
   return strcmp(a->vtable->identify(a), name) == 0;
 }
@@ -755,7 +755,7 @@ GEN_RETURN_F(float)
 GEN_RETURN_F(double)
 GEN_RETURN_F(bool)
 
-char *string_array[2] = { "Hello", "world" };
+const char *string_array[2] = { "Hello", "world" };
 int32_t int_array[5] = { 0, 1, 2, 3, 4 };
 
 void check_ones(const int *p, size_t sz)

tests/clib/test_functions.h

@@ -74,7 +74,7 @@ struct triple {
 extern struct triple add_triples(struct triple, struct triple);
 struct animal;
 struct chorse;
-extern int check_name(struct animal *, char *);
+extern int check_name(struct animal *, const char *);
 extern char *chorse_colour(struct chorse *);
 extern char *chorse_say(struct animal *);
 extern char *chorse_identify(struct animal *);
@@ -264,7 +264,7 @@ float callback_returns_float(float (*f)(void));
 double callback_returns_double(double (*f)(void));
 bool callback_returns_bool(bool (*f)(void));
 
-extern char *string_array[2];
+extern const char *string_array[2];
 extern int32_t int_array[5];
 
 void check_ones(const int *, size_t);

tests/test-type_printing/test_type_printing.ml

@@ -533,7 +533,7 @@ let test_view_printing _ =
   begin
     (* By default, views are printed as the underlying type *)
 
-    assert_typ_printed_as ~name:"a" "char *a"
+    assert_typ_printed_as ~name:"a" "char const* a"
       string;
 
     let v : unit typ = view ~read:(fun _ -> ()) ~write:(fun () () -> ())