#include <stdio.h>
+#ifdef HAVE_WINDOWS_H
+#include <windows.h>
+#endif
+
/* -----------------------------------------------------------------------------
General message generation functions
-------------------------------------------------------------------------- */
// Default to the stdio implementation of these hooks.
-RtsMsgFunction *fatalInternalErrorFn = stdioFatalInternalErrorFn;
-RtsMsgFunction *debugMsgFn = stdioDebugMsgFn;
-RtsMsgFunction *errorMsgFn = stdioErrorMsgFn;
+RtsMsgFunction *fatalInternalErrorFn = rtsFatalInternalErrorFn;
+RtsMsgFunction *debugMsgFn = rtsDebugMsgFn;
+RtsMsgFunction *errorMsgFn = rtsErrorMsgFn;
void
barf(char *s, ...)
stg_exit(EXIT_INTERNAL_ERROR); // just in case fatalInternalErrorFn() returns
}
+void
+_assertFail(char *filename, unsigned int linenum)
+{
+ barf("ASSERTION FAILED: file %s, line %u\n", filename, linenum);
+}
+
void
errorBelch(char *s, ...)
{
stdio versions of the message functions
-------------------------------------------------------------------------- */
-void
-stdioFatalInternalErrorFn(char *s, va_list ap)
+#define BUFSIZE 512
+
+#if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
+static int
+isGUIApp()
{
- /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
- if (prog_argv != NULL && prog_name != NULL) {
- fprintf(stderr, "%s: internal error: ", prog_name);
- } else {
- fprintf(stderr, "internal error: ");
- }
- vfprintf(stderr, s, ap);
- fprintf(stderr, "\n");
- fprintf(stderr, " Please report this as a bug to glasgow-haskell-bugs@haskell.org,\n or http://www.sourceforge.net/projects/ghc/\n");
- fflush(stderr);
- stg_exit(EXIT_INTERNAL_ERROR);
+ PIMAGE_DOS_HEADER pDOSHeader;
+ PIMAGE_NT_HEADERS pPEHeader;
+
+ pDOSHeader = (PIMAGE_DOS_HEADER) GetModuleHandleA(NULL);
+ if (pDOSHeader->e_magic != IMAGE_DOS_SIGNATURE)
+ return 0;
+
+ pPEHeader = (PIMAGE_NT_HEADERS) ((char *)pDOSHeader + pDOSHeader->e_lfanew);
+ if (pPEHeader->Signature != IMAGE_NT_SIGNATURE)
+ return 0;
+
+ return (pPEHeader->OptionalHeader.Subsystem == IMAGE_SUBSYSTEM_WINDOWS_GUI);
}
+#endif
void
-stdioErrorMsgFn(char *s, va_list ap)
+rtsFatalInternalErrorFn(char *s, va_list ap)
{
- /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
- if (prog_argv != NULL && prog_name != NULL) {
- fprintf(stderr, "%s: ", prog_name);
- }
- vfprintf(stderr, s, ap);
- fprintf(stderr, "\n");
+#if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
+ if (isGUIApp())
+ {
+ char title[BUFSIZE], message[BUFSIZE];
+
+ snprintf(title, BUFSIZE, "%s: internal error", prog_name);
+ vsnprintf(message, BUFSIZE, s, ap);
+
+ MessageBox(NULL /* hWnd */,
+ message,
+ title,
+ MB_OK | MB_ICONERROR | MB_TASKMODAL
+ );
+ }
+ else
+#endif
+ {
+ /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
+ if (prog_argv != NULL && prog_name != NULL) {
+ fprintf(stderr, "%s: internal error: ", prog_name);
+ } else {
+ fprintf(stderr, "internal error: ");
+ }
+ vfprintf(stderr, s, ap);
+ fprintf(stderr, "\n");
+ fprintf(stderr, " Please report this as a compiler bug. See:\n http://www.haskell.org/ghc/reportabug\n");
+ fflush(stderr);
+ }
+
+ abort();
+ // stg_exit(EXIT_INTERNAL_ERROR);
}
void
-stdioDebugMsgFn(char *s, va_list ap)
+rtsErrorMsgFn(char *s, va_list ap)
{
- /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
- vfprintf(stderr, s, ap);
- fflush(stderr);
+#if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
+ if (isGUIApp())
+ {
+ char buf[BUFSIZE];
+ int r;
+
+ r = vsnprintf(buf, BUFSIZE, s, ap);
+ if (r > 0 && r < BUFSIZE) {
+ MessageBox(NULL /* hWnd */,
+ buf,
+ prog_name,
+ MB_OK | MB_ICONERROR | MB_TASKMODAL
+ );
+ }
+ }
+ else
+#endif
+ {
+ /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
+ if (prog_argv != NULL && prog_name != NULL) {
+ fprintf(stderr, "%s: ", prog_name);
+ }
+ vfprintf(stderr, s, ap);
+ fprintf(stderr, "\n");
+ }
}
+void
+rtsDebugMsgFn(char *s, va_list ap)
+{
+#if defined(cygwin32_TARGET_OS) || defined (mingw32_TARGET_OS)
+ if (isGUIApp())
+ {
+ char buf[BUFSIZE];
+ int r;
+
+ r = vsnprintf(buf, BUFSIZE, s, ap);
+ if (r > 0 && r < BUFSIZE) {
+ OutputDebugString(buf);
+ }
+ }
+ else
+#endif
+ {
+ /* don't fflush(stdout); WORKAROUND bug in Linux glibc */
+ vfprintf(stderr, s, ap);
+ fflush(stderr);
+ }
+}