add one more underscore to chkstk, use program path for install path (windows)

1 files changed, 45 insertions, 19 deletions

diff --git a/translate/mcode/windows/windows_default_path.adb b/translate/mcode/windows/windows_default_path.adb
index 8ad27ed..2538e5d 100644
--- a/translate/mcode/windows/windows_default_path.adb
+++ b/translate/mcode/windows/windows_default_path.adb
@@ -1,19 +1,45 @@
-with GNAT.Registry; use GNAT.Registry;

-

-package body Windows_Default_Path is

-   function Get_Windows_Default_Path return String

-   is

-      Key : HKEY;

-   begin

-      Key := Open_Key (HKEY_LOCAL_MACHINE, "Software\Ghdl");

-      declare

-	 Res : String := Query_Value (Key, "Install_Dir");

-      begin

-	 return Res & "\lib\";

-      end;

-   exception

-      when Registry_Error =>

-	 --  Do not write an error message, but return a useful default path.

-	 return "{missing HKLM\Software\Ghdl\Install_Dir key}\lib\";

-   end Get_Windows_Default_Path;

-end Windows_Default_Path;

+with Interfaces.C; use Interfaces.C;
+with System; use System;
+
+package body Windows_Default_Path is
+
+   subtype DWORD is Interfaces.C.Unsigned_Long;
+   subtype LPWSTR is String;
+   subtype HINSTANCE is Address;
+   function GetModuleFileName (Inst : HINSTANCE; Buf : Address; Size : DWORD)
+                              return DWORD;
+   pragma Import (Stdcall, GetModuleFileName, "GetModuleFileNameA");
+
+   function Get_Windows_Default_Path return String
+   is
+      File : String (1 .. 256);
+      Size : DWORD;
+      P : Natural;
+   begin
+      --  Get exe file path.
+      Size := GetModuleFileName (Null_Address, File'Address, File'Length);
+      if Size = 0 or Size = File'Length then
+         return "{cannot find install path}\lib";
+      end if;
+
+      --  Remove Program file.
+      P := Natural (Size);
+      while P > 0 loop
+         exit when File (P) = '\';
+         exit when File (P) = ':' and P = 2;
+         P := P - 1;
+      end loop;
+      if File (P) = '\' and P > 1 then
+         --  Remove directory
+         P := P - 1;
+         while P > 0 loop
+            exit when File (P) = '\';
+            exit when File (P) = ':' and P = 2;
+            P := P - 1;
+         end loop;
+      end if;
+
+      return File (1 .. P) & "lib";
+   end Get_Windows_Default_Path;
+end Windows_Default_Path;
+