Ocaml 405 fix (#2221)

* Fixed string related build warnings
* Changed Failures to accept all strings
* Updated pprzlink for v405 fix
* updated use of lowercase, uppercase and capitalize

sw/lib/ocaml/Makefile

@@ -71,6 +71,9 @@ ifeq ($(shell test $(OCAMLC_MAJOR) -ge 4; echo $$?),0)
 ifeq ($(shell test $(OCAMLC_MINOR) -ge 2; echo $$?),0)
 # the Bytes module is available since OCaml 4.02.0
 CAMLP4_DEFS += -DHAS_BYTES_MODULE
+ifeq ($(shell test $(OCAMLC_MINOR) -ge 4; echo $$?),0)
+CAMLP4_DEFS += -DOCAML_V404
+endif
 endif
 endif
 PP_OPTS = -pp "camlp4o pa_macro.cmo $(CAMLP4_DEFS)"

sw/lib/ocaml/compat.ml

@@ -43,12 +43,6 @@ let bytes_make = fun n c->
 let bytes_copy = fun s->
   BYTES.copy s
 
-let bytes_lowercase = fun s->
-  BYTES.lowercase s
-
-let bytes_uppercase = fun s->
-  BYTES.uppercase s
-
 let bytes_blit = fun src srcoff dst dstoff len->
   BYTES.blit src srcoff dst dstoff len
 
@@ -75,3 +69,19 @@ let bytes_set = fun s n c->
 
 let bytes_iter = fun f s->
   BYTES.iter f s
+
+IFDEF OCAML_V404 THEN
+let lowercase_ascii = BYTES.lowercase_ascii
+
+let uppercase_ascii = BYTES.uppercase_ascii
+
+let capitalize_ascii = BYTES.capitalize_ascii
+
+ELSE
+let lowercase_ascii = BYTES.lowercase
+
+let uppercase_ascii = BYTES.uppercase
+
+let capitalize_ascii = BYTES.capitalize
+
+END

sw/lib/ocaml/compat.mli

@@ -27,8 +27,6 @@ val bytes_contains : string -> char -> bool
 val bytes_length : string -> int
 val bytes_make : int -> char -> string
 val bytes_copy : string -> string
-val bytes_lowercase : string -> string
-val bytes_uppercase : string -> string
 val bytes_blit : string -> int -> string -> int -> int -> unit
 val bytes_sub : string -> int -> int -> string
 val bytes_index : string -> char -> int
@@ -38,3 +36,7 @@ val bytes_get : string -> int -> char
 val bytes_compare : string -> string -> int
 val bytes_set : string -> int -> char -> unit
 val bytes_iter : (char -> unit) -> string -> unit
+
+val lowercase_ascii : string -> string
+val uppercase_ascii : string -> string
+val capitalize_ascii : string -> string

sw/lib/ocaml/expr_lexer.mll

@@ -63,7 +63,7 @@ rule token = parse
     try
       Expr_parser.expression token lexbuf
     with
-      Failure("lexing: empty token") ->
+      Failure _ ->
 	Printf.fprintf stderr "Lexing error in '%s': unexpected char: '%c' \n"
 	  s (Lexing.lexeme_char lexbuf 0);
 	exit 1

sw/lib/ocaml/extXml.ml

@@ -44,7 +44,7 @@ let child = fun xml ?select c ->
 
   (* Let's try with a numeric index *)
   try (Array.of_list children).(int_of_string c)
-  with Failure "int_of_string" -> (* Bad luck. Go through the children *)
+  with Failure _ -> (* Bad luck. Go through the children *)
     find children
 
 
@@ -75,7 +75,7 @@ let attrib_option = fun xml attr ->
   try Some (Xml.attrib xml attr)
   with Xml.No_attribute _ -> None
 
-let tag_is = fun x v -> Compat.bytes_lowercase (Xml.tag x) = Compat.bytes_lowercase v
+let tag_is = fun x v -> Compat.lowercase_ascii (Xml.tag x) = Compat.lowercase_ascii v
 
 let attrib_or_default = fun x a default ->
   try Xml.attrib x a
@@ -148,7 +148,7 @@ let my_to_string_fmt = fun tab_attribs x ->
 
 
 let to_string_fmt = fun ?(tab_attribs = false) xml ->
-  let l = Compat.bytes_lowercase in
+  let l = Compat.lowercase_ascii in
   let rec lower = function
     | Xml.PCData _ as x -> x
     | Xml.Element (t, ats, cs) ->
@@ -159,7 +159,7 @@ let to_string_fmt = fun ?(tab_attribs = false) xml ->
 
 
 let subst_attrib = fun attrib value xml ->
-  let u = Compat.bytes_uppercase in
+  let u = Compat.uppercase_ascii in
   let uattrib = u attrib in
   match xml with
   | Xml.Element (tag, attrs, children) ->

sw/lib/ocaml/fp_proc.ml

@@ -38,7 +38,7 @@ let parse_expression = fun s ->
   try
     Expr_parser.expression Expr_lexer.token lexbuf
   with
-      Failure("lexing: empty token") ->
+      Failure _ ->
         fprintf stderr "Lexing error in '%s': unexpected char: '%c' \n"
           s (Lexing.lexeme_char lexbuf 0);
         exit 1
@@ -72,7 +72,7 @@ let transform_values = fun attribs_not_modified env attribs ->
   List.map
     (fun (a, v) ->
       let v' =
-        if List.mem (String.lowercase a) attribs_not_modified
+        if List.mem (Compat.lowercase_ascii a) attribs_not_modified
         then v
         else transform_expression env (parse_expression v) in
       (a, v'))
@@ -83,7 +83,7 @@ let prefix_or_deroute = fun prefix reroutes name attribs ->
   List.map
     (fun (a, v) ->
       let v' =
-        if String.lowercase a = name then
+        if Compat.lowercase_ascii a = name then
           try List.assoc v reroutes with
               Not_found -> prefix v
         else v in
@@ -105,7 +105,7 @@ let transform_stage = fun prefix reroutes env xml ->
   let rec tr = fun xml ->
     match xml with
         Xml.Element (tag, attribs, children) -> begin
-          match String.lowercase tag with
+          match Compat.lowercase_ascii tag with
               "exception" ->
                 transform_exception prefix reroutes env xml
             | "while" ->
@@ -276,7 +276,7 @@ let process_includes = fun dir xml ->
 
 
 let remove_attribs = fun xml names ->
-  List.filter (fun (x,_) -> not (List.mem (String.lowercase x) names)) (Xml.attribs xml)
+  List.filter (fun (x,_) -> not (List.mem (Compat.lowercase_ascii x) names)) (Xml.attribs xml)
 
 let xml_assoc_attrib = fun a v xmls ->
   List.find (fun x -> ExtXml.attrib x a = v) xmls
@@ -327,7 +327,7 @@ let replace_from = fun stage waypoints ->
 
 let process_stage = fun stage waypoints ->
   let rec do_it = fun stage ->
-    match String.lowercase (Xml.tag stage) with
+    match Compat.lowercase_ascii (Xml.tag stage) with
         "go" | "stay" | "circle" ->
           replace_from (replace_wp stage waypoints) waypoints
 

sw/lib/ocaml/gen_common.ml

@@ -160,7 +160,7 @@ let get_autopilot_of_airframe = fun ?target xml ->
  * Returns the boolean expression of targets of a module *)
 let get_targets_of_module = fun xml ->
   Xml.fold (fun a x ->
-    match Compat.bytes_lowercase (Xml.tag x) with
+    match Compat.lowercase_ascii (Xml.tag x) with
     | "makefile" when a = Var "" -> targets_of_field x Env.default_module_targets
     | "makefile" -> Or (a, targets_of_field x Env.default_module_targets)
     | _ -> a

sw/lib/ocaml/mapCanvas.ml

@@ -587,7 +587,7 @@ object (self)
           end
           | _ ->    false
       with
-          Invalid_argument "ml_lookup_from_c" -> (* Raised GdkEvent.get_type *)
+          Invalid_argument _ -> (* Raised GdkEvent.get_type *)
             false
 
 

sw/lib/ocaml/mapFP.ml

@@ -34,7 +34,7 @@ let float_attr = fun xml a -> float_of_string (ExtXml.attrib xml a)
 let rec assoc_nocase at = function
 [] -> raise Not_found
   | (a, v)::avs ->
-    if Compat.bytes_uppercase at = Compat.bytes_uppercase a then v else assoc_nocase at avs
+    if Compat.uppercase_ascii at = Compat.uppercase_ascii a then v else assoc_nocase at avs
 
 (** Returns the WGS84 coordinates of a waypoint, either from its relative x and
     y coordinates or from its lat and long *)
@@ -203,7 +203,7 @@ let display_kml = fun ?group color geomap xml ->
   try
     let document = ExtXml.child xml "Document" in
     let rec loop = fun child ->
-      let tag = Compat.bytes_lowercase (Xml.tag child) in
+      let tag = Compat.lowercase_ascii (Xml.tag child) in
       match tag with
         | "linestring" | "linearring" ->
             let coordinates = ExtXml.child child "coordinates" in
@@ -266,7 +266,7 @@ class flight_plan = fun ?format_attribs ?editable ~show_moved geomap color fp_dt
     let waypoints = ExtXml.child xml "waypoints" in
     try
       List.fold_left (fun l x ->
-        match Compat.bytes_lowercase (Xml.tag x) with
+        match Compat.lowercase_ascii (Xml.tag x) with
             "kml" ->
               let file = ExtXml.attrib x "file" in
               display_kml ~group:wpts_group#group color geomap (ExtXml.parse_file (Env.flight_plans_path // file));

sw/lib/ocaml/papget.ml

@@ -368,7 +368,7 @@ object (self)
     let (x, y) = item#xy in
     let attrs =
       [ "type", msg_obj#type_;
-        "display", Compat.bytes_lowercase item#renderer#tag;
+        "display", Compat.lowercase_ascii item#renderer#tag;
         "x", sprintf "%.0f" x; "y", sprintf "%.0f" y ] in
     Xml.Element ("papget", attrs, scale_prop::val_props@renderer_props)
 end
@@ -387,7 +387,7 @@ object
     let (x, y) = item#xy in
     let attrs =
       [ "type", type_;
-        "display", Compat.bytes_lowercase item#renderer#tag;
+        "display", Compat.lowercase_ascii item#renderer#tag;
         "x", sprintf "%.0f" x; "y", sprintf "%.0f" y ] in
     Xml.Element ("papget", attrs, properties@props)
 end
@@ -416,7 +416,7 @@ object (self)
     let (x, y) = item#xy in
     let attrs =
       [ "type", "video_plugin";
-        "display", Compat.bytes_lowercase item#renderer#tag;
+        "display", Compat.lowercase_ascii item#renderer#tag;
         "x", sprintf "%.0f" x; "y", sprintf "%.0f" y ] in
     Xml.Element ("papget", attrs, properties@props)
   initializer ignore(adj#connect#value_changed (fun () -> self#update_zoom (string_of_float adj#value)))

sw/lib/ocaml/srtm.ml

@@ -87,7 +87,8 @@ let area_of_tile = fun tile ->
   let area = open_compressed "srtm.data.bz2" in
   let rec _area_of_tile = fun () ->
     try
-      Scanf.fscanf area "%s %s\n" (fun t a ->
+      let ib = Scanf.Scanning.from_channel area in
+      Scanf.bscanf ib "%s %s\n" (fun t a ->
         if t = tile then a
         else _area_of_tile ())
     with

sw/lib/ocaml/xmlEdit.ml

@@ -352,21 +352,21 @@ let set_attribs = fun ((model, path):node) attribs ->
 let rec replace_assoc a v = function
 [] -> [(a, v)]
   | (a', v')::l ->
-    if a = Compat.bytes_uppercase a'
+    if a = Compat.uppercase_ascii a'
     then (a, v)::l
     else (a', v')::replace_assoc a v l
 
 let set_attrib = fun node (a, v) ->
   let atbs = attribs node in
-  set_attribs node (replace_assoc (Compat.bytes_uppercase a) v atbs)
+  set_attribs node (replace_assoc (Compat.uppercase_ascii a) v atbs)
 
 let attrib = fun node at ->
-  let at = Compat.bytes_uppercase at in
+  let at = Compat.uppercase_ascii at in
   let ats = attribs node in
   let rec loop = function
   [] -> raise Not_found
     | (a,v)::avs ->
-      if Compat.bytes_uppercase a = at then v else loop avs in
+      if Compat.uppercase_ascii a = at then v else loop avs in
   loop ats
 
 let tag = fun ((model, path):node) ->