virt-ctrl/mingw-gcc-wrapper.ml

   1 (* Wrapper around 'gcc'.  On MinGW, this wrapper understands the '@...'\r
   2  * syntax for extending the command line.\r
   3  *)\r
   4 \r
   5 open Printf\r
   6 open Unix\r
   7 \r
   8 let (//) = Filename.concat\r
   9 \r
  10 (* Substitute any @... arguments with the file content. *)\r
  11 let rec input_all_lines chan =\r
  12   try\r
  13     let line = input_line chan in\r
  14     line :: input_all_lines chan\r
  15   with\r
  16     End_of_file -> []\r
  17 \r
  18 let argv = Array.map (\r
  19   fun arg ->\r
  20     if arg.[0] = '@' then (\r
  21       let chan = open_in (String.sub arg 1 (String.length arg - 1)) in\r
  22       let lines = input_all_lines chan in\r
  23       close_in chan;\r
  24       lines\r
  25     ) else\r
  26       [arg]\r
  27 ) Sys.argv\r
  28 \r
  29 let argv = Array.to_list argv\r
  30 let argv = List.flatten argv\r
  31 \r
  32 (* Find the real gcc.exe on $PATH, but ignore any '.' elements in the path.\r
  33  * Note that on Windows, $PATH is split with ';' characters.\r
  34  *)\r
  35 let rec split_find str sep f =\r
  36   try\r
  37     let i = String.index str sep in\r
  38     let n = String.length str in\r
  39     let str, str' = String.sub str 0 i, String.sub str (i+1) (n-i-1) in\r
  40     match f str with\r
  41     | None -> split_find str' sep f  (* not found, keep searching *)\r
  42     | Some found -> found\r
  43   with\r
  44     Not_found ->\r
  45       match f str with\r
  46       | None -> raise Not_found (* not found at all *)\r
  47       | Some found -> found\r
  48 \r
  49 let exists filename =\r
  50   try access filename [F_OK]; true with Unix_error _ -> false\r
  51 \r
  52 let gcc =\r
  53   split_find (Sys.getenv "PATH") ';'\r
  54     (function\r
  55      | "." -> None (* ignore current directory in path *)\r
  56      | path ->\r
  57        let gcc = path // "gcc.exe" in\r
  58        if exists gcc then Some gcc else None)\r
  59 \r
  60 (* Finally execute the real gcc with the full argument list.\r
  61  * Can't use execv here because then the parent process (ocamlopt) thinks\r
  62  * that this process has finished and deletes all the temp files.  Stupid\r
  63  * Windoze!\r
  64  *)\r
  65 let _ =\r
  66   let argv = List.map Filename.quote (List.tl argv) in\r
  67   let cmd = String.concat " " (gcc :: argv) in\r
  68   eprintf "mingw-gcc-wrapper: %s\n%!" cmd;\r
  69   let r = Sys.command cmd in\r
  70   exit r\r