X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fwin32-foreign-load.lisp;h=f62718d835c7fb8842c54f3e62a9ae24ef9148db;hb=4ba392170e98744f0ef0b8e08a5d42b988f1d0c9;hp=bb431f15dd568911c0f7c9006a2fe175fe9a418a;hpb=fe19212267bef96fedb712ebb43abc91631aea18;p=sbcl.git

diff --git a/src/code/win32-foreign-load.lisp b/src/code/win32-foreign-load.lisp
index bb431f1..f62718d 100644
--- a/src/code/win32-foreign-load.lisp
+++ b/src/code/win32-foreign-load.lisp
@@ -11,39 +11,68 @@
 
 (in-package "SB!ALIEN")
 
-(define-alien-type hinstance long)
+(define-alien-type hinstance signed)
 
-(define-alien-routine ("LoadLibraryA@4" loadlibrary) hinstance
+(define-alien-routine ("LoadLibraryA" loadlibrary) hinstance
   (file c-string))
 
-(define-alien-routine ("FreeLibrary@4" freelibrary) int
+(define-alien-routine ("FreeLibrary" freelibrary) int
   (handle hinstance))
 
-(define-alien-routine ("GetProcAddress@8" getprocaddress) system-area-pointer
+(define-alien-routine ("GetProcAddress" getprocaddress) system-area-pointer
   (handle hinstance)
   (symbol c-string))
 
-(define-alien-routine ("GetLastError@0" getlasterror) unsigned-int)
+(define-alien-routine ("SetStdHandle" set-std-handle)
+   void
+ (id int)
+ (handle int))
 
-(defun dlopen-or-lose (obj)
-  (let* ((namestring (shared-object-namestring obj))
-         (handle (loadlibrary namestring)))
-    (aver namestring)
-    (when (zerop handle)
-      (setf (shared-object-handle obj) nil)
-      (error "Error opening shared object ~S:~%  ~A."
-             namestring (getlasterror)))
-    (setf (shared-object-handle obj) handle)
-    handle))
+(sb!alien:define-alien-routine ("GetStdHandle" get-std-handle)
+   sb!alien:int
+ (id sb!alien:int))
+
+(define-alien-routine ("GetModuleHandleW" get-module-handle)
+    hinstance
+  (name (c-string :external-format :ucs-2)))
+
+(defvar *reset-stdio-on-dlopen* t)
+
+(defconstant +stdio-handle+ -10)
+
+(defun loadlibrary-without-stdio (namestring)
+  (flet ((loadlibrary (namestring)
+           (loadlibrary namestring)))
+   (if *reset-stdio-on-dlopen*
+       (let ((stdio (get-std-handle +stdio-handle+)))
+         (unwind-protect
+              (progn
+                (set-std-handle +stdio-handle+ -1)
+                (loadlibrary namestring))
+           (set-std-handle +stdio-handle+ stdio)))
+       (loadlibrary namestring))))
+
+(defun dlopen-or-lose (&optional obj)
+  (if obj
+      (let* ((namestring (shared-object-namestring obj))
+             (handle (loadlibrary-without-stdio namestring)))
+        (aver namestring)
+        (when (zerop handle)
+          (setf (shared-object-handle obj) nil)
+          (error "Error opening shared object ~S:~% ~A"
+                 namestring (sb!win32:format-system-message (sb!win32:get-last-error))))
+        (setf (shared-object-handle obj) handle)
+        handle)
+      (extern-alien "runtime_module_handle" hinstance)))
 
 (defun dlclose-or-lose (&optional (obj nil objp))
   (when (and objp (shared-object-handle obj))
     (unless (freelibrary (shared-object-handle obj))
       (cerror "Ignore the error and continue as if closing succeeded."
               "FreeLibrary() caused an error while trying to close ~
-               shared object ~S: ~S"
+               shared object ~S:~% ~A"
               (shared-object-namestring obj)
-              (getlasterror)))
+              (sb!win32:format-system-message (sb!win32:get-last-error))))
     (setf (shared-object-handle obj) nil)))
 
 (defun find-dynamic-foreign-symbol-address (symbol)
@@ -59,11 +88,27 @@
   ;; GetProcAddress() won't return NULL on success.
   (let* ((extern (coerce symbol 'base-string))
          (result nil))
-    (dolist (obj *shared-objects*)
-      (let ((handle (shared-object-handle obj)))
-        (when handle
-          (setf result (sap-int (getprocaddress handle extern)))
-          (when (not (zerop result))
-            (return result)))))))
-
+    (dolist (handle
+              (cons *runtime-dlhandle*
+                    (mapcar #'shared-object-handle *shared-objects*)))
+      (when handle
+        (setf result (sap-int (getprocaddress handle extern)))
+        (when (not (zerop result))
+          (return result))))))
 
+(defun runtime-exported-symbols ()
+  ;; TODO: reimplement for x86-64. Not so hard.
+  (let* ((image-base (extern-alien "runtime_module_handle" system-area-pointer))
+         (pe-base (sap+ image-base (sap-ref-32 image-base 60)))
+         (export-directory (sap+ pe-base (- #!+x86 248 #!+x86-64 264 (* 16 8))))
+         (export-data (sap+ image-base (sap-ref-32 export-directory 0)))
+         (n-functions (sap-ref-32 export-data 20))
+         (n-names (sap-ref-32 export-data 24))
+         (functions-sap (sap+ image-base (sap-ref-32 export-data 28)))
+         (names-sap (sap+ image-base (sap-ref-32 export-data 32))))
+    (loop repeat (min n-functions n-names)
+          for offset from 0 by #.sb!vm::n-word-bytes
+          collect
+       (cons
+         (sap-int (sap+ image-base (sap-ref-32 functions-sap offset)))
+         (sap-int (sap+ image-base (sap-ref-32 names-sap offset)))))))