[project @ 2000-03-23 14:54:20 by sewardj]

[ghc-hetmet.git] / ghc / interpreter / dynamic.c

diff --git a/ghc/interpreter/dynamic.c b/ghc/interpreter/dynamic.c
index f6d7fdd..1f37491 100644 (file)
--- a/ghc/interpreter/dynamic.c
+++ b/ghc/interpreter/dynamic.c
@@ -1,116 +1,168 @@
-/* -*- mode: hugs-c; -*- */
+
 /* --------------------------------------------------------------------------
  * Dynamic loading (of .dll or .so files) for Hugs
  *
- * Copyright (c) The University of Nottingham and Yale University, 1994-1997.
- * All rights reserved. See NOTICE for details and conditions of use etc...
- * Hugs version 1.4, December 1997
+ * The Hugs 98 system is Copyright (c) Mark P Jones, Alastair Reid, the
+ * Yale Haskell Group, and the Oregon Graduate Institute of Science and
+ * Technology, 1994-1999, All rights reserved.  It is distributed as
+ * free software under the license in the file "License", which is
+ * included in the distribution.
  *
  * $RCSfile: dynamic.c,v $
- * $Revision: 1.2 $
- * $Date: 1998/12/02 13:22:06 $
+ * $Revision: 1.15 $
+ * $Date: 2000/03/23 14:54:21 $
  * ------------------------------------------------------------------------*/
 
-#include "prelude.h"
+#include "hugsbasictypes.h"
 #include "storage.h"
 #include "errors.h"
-#include "dynamic.h"
+#include "connect.h"
 
-#if HAVE_DLFCN_H /* eg LINUX, SOLARIS, ULTRIX */
+#if HAVE_WINDOWS_H && !defined(__MSDOS__)
 
-#include <stdio.h>
-#include <dlfcn.h>
+#include <windows.h>
+
+void* getDLLSymbol(line,dll0,symbol0) /* load dll and lookup symbol */
+Int    line;
+String dll0;
+String symbol0; {
+    void*      sym;
+    char       dll[1000];
+    char       symbol[100];
+    ObjectFile instance;
+
+    if (strlen(dll0) > 996-strlen(installDir)) {
+       ERRMSG(line) "Excessively long library name:\n%s\n",dll0
+       EEND;
+    }
+    dll[0] = 0;
+    if (strcmp("nHandle",dll0)==0) strcat(dll,installDir);
+    strcat(dll,dll0);
+    strcat(dll, ".dll");
+
+    if (strlen(symbol0) > 96) {
+       ERRMSG(line) "Excessively long symbol name:\n%s\n",symbol0
+       EEND;
+    }
+    strcpy(&(symbol[1]),symbol0); 
+    symbol[0] = '_';
 
-ObjectFile loadLibrary(fn)
-String fn; {
-    return dlopen(fn,RTLD_NOW | RTLD_GLOBAL);
+    instance = LoadLibrary(dll);
+    if (NULL == instance) {
+        /* GetLastError allegedly provides more detail - in practice,
+        * it tells you nothing more.
+         */
+        ERRMSG(line) "Can't open library \"%s\"", dll
+        EEND;
+    }
+    sym = GetProcAddress(instance,symbol0);
+    return sym;
 }
 
-void* lookupSymbol(file,symbol)
-ObjectFile file;
-String symbol; {
-    return dlsym(file,symbol)
+Bool stdcallAllowed ( void )
+{
+   return TRUE;
 }
 
-void* getDLLSymbol(dll,symbol)  /* load dll and lookup symbol */
-String dll;
+
+
+
+
+
+#elif HAVE_DLFCN_H /* eg LINUX, SOLARIS, ULTRIX */
+
+#include <stdio.h>
+#include <dlfcn.h>
+
+void* getDLLSymbol(line,dll0,symbol)  /* load dll and lookup symbol */
+Int    line;
+String dll0;
 String symbol; {
+    void*      sym;
+    char       dll[1000];
+    ObjectFile instance;
+    if (strlen(dll0) > 996-strlen(installDir)) {
+       ERRMSG(line) "Excessively long library name:\n%s\n",dll0
+       EEND;
+    }
+    dll[0] = 0;
+    if (strcmp("nHandle",dll0)==0) strcat(dll,installDir);
+    strcat(dll,dll0);
+    strcat(dll, ".so");
 #ifdef RTLD_NOW
-    ObjectFile instance = dlopen(dll,RTLD_NOW);
+    instance = dlopen(dll,RTLD_NOW);
 #elif defined RTLD_LAZY /* eg SunOS4 doesn't have RTLD_NOW */
-    ObjectFile instance = dlopen(dll,RTLD_LAZY);
+    instance = dlopen(dll,RTLD_LAZY);
 #else /* eg FreeBSD doesn't have RTLD_LAZY */
-    ObjectFile instance = dlopen(dll,1);
+    instance = dlopen(dll,1);
 #endif
+
     if (NULL == instance) {
-        ERRMSG(0) "Error %s while importing DLL \"%s\"", dlerror(), dll
+       ERRMSG(line) "Can't open library \"%s\":\n      %s\n",dll,dlerror()
         EEND;
     }
-    return dlsym(instance,symbol);
+    if ((sym = dlsym(instance,symbol)))
+        return sym;
+
+    ERRMSG(line) "Can't find symbol \"%s\" in library \"%s\"",symbol,dll
+    EEND;
 }
 
+Bool stdcallAllowed ( void )
+{
+   return FALSE;
+}
+
+
+
+
+
+
 #elif HAVE_DL_H /* eg HPUX */
 
 #include <dl.h>
 
-void* getDLLSymbol(dll,symbol)  /* load dll and lookup symbol */
-String dll;
+void* getDLLSymbol(line,dll0,symbol)  /* load dll and lookup symbol */
+Int    line;
+String dll0;
 String symbol; {
     ObjectFile instance = shl_load(dll,BIND_IMMEDIATE,0L);
     void* r;
     if (NULL == instance) {
-        ERRMSG(0) "Error while importing DLL \"%s\"", dll
+        ERRMSG(line) "Error while importing DLL \"%s\"", dll0
         EEND;
     }
     return (0 == shl_findsym(&instance,symbol,TYPE_PROCEDURE,&r)) ? r : 0;
 }
 
-#elif HAVE_WINDOWS_H && !defined(__MSDOS__)
+Bool stdcallAllowed ( void )
+{
+   return FALSE;
+}
 
-#include <windows.h>
 
-ObjectFile loadLibrary(fn)
-String fn; {
-    return LoadLibrary(fn);
-}
 
-void* lookupSymbol(file,symbol)
-ObjectFile file;
-String symbol; {
-    return GetProcAddress(file,symbol);
-}
 
-const char *dlerror(void)
-{
-   return "<unknown>";
-}
 
-void* getDLLSymbol(dll,symbol)  /* load dll and lookup symbol */
-String dll;
-String symbol; {
-    ObjectFile instance = LoadLibrary(dll);
-    if (NULL == instance) {
-        /* GetLastError allegedly provides more detail - in practice,
-        * it tells you nothing more.
-         */
-        ERRMSG(0) "Error while importing DLL \"%s\"", dll
-        EEND;
-    }
-    return GetProcAddress(instance,symbol);
-}
 
 #else /* Dynamic loading not available */
 
-void* getDLLSymbol(dll,symbol)  /* load dll and lookup symbol */
-String dll;
+void* getDLLSymbol(line,dll0,symbol)  /* load dll and lookup symbol */
+Int    line;
+String dll0;
 String symbol; {
 #if 1 /* very little to choose between these options */
     return 0;
 #else
-    ERRMSG(0) "This Hugs build does not support dynamic loading\n"
+    ERRMSG(line) "This Hugs build does not support dynamic loading\n"
     EEND;
 #endif
 }
 
+Bool stdcallAllowed ( void )
+{
+   return FALSE;
+}
+
 #endif /* Dynamic loading not available */