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