1.0.22.11: name *pcl-lock*
[sbcl.git] / src / code / win32-foreign-load.lisp
1 ;;;; Loading shared object files, Win32 specifics
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!ALIEN")
13
14 (define-alien-type hinstance long)
15
16 (define-alien-routine ("LoadLibraryA@4" loadlibrary) hinstance
17   (file c-string))
18
19 (define-alien-routine ("FreeLibrary@4" freelibrary) int
20   (handle hinstance))
21
22 (define-alien-routine ("GetProcAddress@8" getprocaddress) system-area-pointer
23   (handle hinstance)
24   (symbol c-string))
25
26 (define-alien-routine ("GetLastError@0" getlasterror) unsigned-int)
27
28 (defun dlopen-or-lose (obj)
29   (let* ((namestring (shared-object-namestring obj))
30          (handle (loadlibrary namestring)))
31     (aver namestring)
32     (when (zerop handle)
33       (setf (shared-object-handle obj) nil)
34       (error "Error opening shared object ~S:~%  ~A."
35              namestring (getlasterror)))
36     (setf (shared-object-handle obj) handle)
37     handle))
38
39 (defun dlclose-or-lose (&optional (obj nil objp))
40   (when (and objp (shared-object-handle obj))
41     (unless (freelibrary (shared-object-handle obj))
42       (cerror "Ignore the error and continue as if closing succeeded."
43               "FreeLibrary() caused an error while trying to close ~
44                shared object ~S: ~S"
45               (shared-object-namestring obj)
46               (getlasterror)))
47     (setf (shared-object-handle obj) nil)))
48
49 (defun find-dynamic-foreign-symbol-address (symbol)
50   ;; On real ELF & dlsym platforms the EXTERN-ALIEN-NAME is a no-op,
51   ;; but on platforms where dlsym is simulated we use the mangled name.
52   ;; Win32 is a special case. It needs EXTERN-ALIEN-NAME to mangle the
53   ;; name for static linkage, but also needs unmangled symbols for
54   ;; GetProcAddress(). So we coerce to base-string instead.
55   ;; Oh, and we assume that all runtime symbols are static-linked.
56   ;; No *runtime-dlhandle* for us.
57   ;; Also, GetProcAddress doesn't call SetLastError(0) on success,
58   ;; and GetLastError() doesn't either. For now, we assume that
59   ;; GetProcAddress() won't return NULL on success.
60   (let* ((extern (coerce symbol 'base-string))
61          (result nil))
62     (dolist (obj *shared-objects*)
63       (let ((handle (shared-object-handle obj)))
64         (when handle
65           (setf result (sap-int (getprocaddress handle extern)))
66           (when (not (zerop result))
67             (return result)))))))
68
69