From 41ec0daab015638bd2340fb0eaf56d49e54bdf13 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sat, 18 Oct 2008 11:58:43 +0000
Subject: [PATCH] 1.0.21.28: implement UNLOAD-SHARED-OBJECT

 * Mostly for CFFI.

 * Add a missing call to TRANSLATE-LOGICAL-PATHNAME to
   TRY-REOPEN-SHARED-OBJECT.
---
 NEWS                        |    3 ++-
 package-data-list.lisp-expr |    1 +
 src/code/foreign-load.lisp  |   24 ++++++++++++++++++++++--
 tests/foreign.test.sh       |    7 +++++++
 version.lisp-expr           |    2 +-
 5 files changed, 33 insertions(+), 4 deletions(-)

diff --git a/NEWS b/NEWS
index 14b6595..a50368b 100644
--- a/NEWS
+++ b/NEWS
@@ -22,7 +22,8 @@ changes in sbcl-1.0.22 relative to 1.0.21:
     Badichi)
   * enhancement: :DONT-SAVE keyword argument has been added to
     LOAD-SHARED-OBJECT for controlling interaction with
-    SAVE-LISP-AND-DIE.
+    SAVE-LISP-AND-DIE, and UNLOAD-SHARED-OBJECT can be used to undo
+    the effects of an earlier LOAD-SHARED-OBJECT call.
   * bug fix: ADJUST-ARRAY on multidimensional arrays used bogusly give
     them a fill pointer unless :DISPLACED-TO or :INITIAL-CONTENTS were
     provided. (reported by Cedric St-Jean)
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index f5e22ab..c1643dd 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -56,6 +56,7 @@ of SBCL which maintained the CMU-CL-style split into two packages.)"
              "NULL-ALIEN"
              "SAP-ALIEN" "SHORT" "SIGNED" "SLOT" "STRUCT"
              "UNDEFINED-ALIEN-ERROR"
+             "UNLOAD-SHARED-OBJECT"
              "UNSIGNED"
              "UNSIGNED-CHAR" "UNSIGNED-INT" "UNSIGNED-LONG" "UNSIGNED-LONG-LONG" "UNSIGNED-SHORT"
              "UTF8-STRING"
diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp
index c8ee2ce..02b2776 100644
--- a/src/code/foreign-load.lisp
+++ b/src/code/foreign-load.lisp
@@ -35,6 +35,7 @@
 (defstruct shared-object pathname namestring handle dont-save)
 
 (defun load-shared-object (pathname &key dont-save)
+  #!+sb-doc
   "Load a shared library / dynamic shared object file / similar foreign
 container specified by designated PATHNAME, such as a .so on an ELF platform.
 
@@ -90,6 +91,23 @@ will be signalled when the core is saved -- this is orthogonal from DONT-SAVE."
           (update-linkage-table))))
     pathname))
 
+(defun unload-shared-object (pathname)
+  #!+sb-doc
+  "Unloads the shared object loaded earlier using the designated PATHNAME with
+LOAD-SHARED-OBJECT, to the degree supported on the platform.
+
+Experimental."
+  (let ((pathname (pathname pathname)))
+    (sb!thread:with-mutex (*shared-objects-lock*)
+      (let ((old (find pathname *shared-objects*
+                       :key #'shared-object-pathname
+                       :test #'equal)))
+        (when old
+          (dlclose-or-lose old)
+          (setf *shared-objects* (remove old *shared-objects*))
+          #!+(and linkage-table (not win32))
+          (update-linkage-table))))))
+
 (defun try-reopen-shared-object (obj)
   (declare (type shared-object obj))
   (tagbody :dlopen
@@ -112,8 +130,10 @@ will be signalled when the core is saved -- this is orthogonal from DONT-SAVE."
               (unless (pathnamep pathname)
                 (format *query-io* "~&Error: invalid pathname.~%")
                 (go :query))
-              (setf (shared-object-pathname obj) pathname
-                    (shared-object-namestring obj) (native-namestring pathname :as-file t))))
+              (setf (shared-object-pathname obj) pathname)
+              (setf (shared-object-namestring obj)
+                    (native-namestring (translate-logical-pathname pathname)
+                                       :as-file t))))
          (go :dlopen))))
   obj)
 
diff --git a/tests/foreign.test.sh b/tests/foreign.test.sh
index 992ae86..01fdc85 100644
--- a/tests/foreign.test.sh
+++ b/tests/foreign.test.sh
@@ -248,6 +248,13 @@ cat > $TEST_FILESTEM.test.lisp <<EOF
     (load-shared-object (truename "$TEST_FILESTEM-c.so"))
     (assert (= 43 late-foo))
     (assert (= 14 (late-bar)))
+    (unload-shared-object (truename "$TEST_FILESTEM-c.so"))
+    (multiple-value-bind (val err) (ignore-errors late-foo)
+      (assert (not val))
+      (assert (typep err 'undefined-alien-error)))
+    (multiple-value-bind (val err) (ignore-errors (late-bar))
+      (assert (not val))
+      (assert (typep err 'undefined-alien-error)))
     (note "/linkage table ok"))
 
   (sb-ext:quit :unix-status $EXIT_LISP_WIN) ; success convention for Lisp program
diff --git a/version.lisp-expr b/version.lisp-expr
index 7434eb8..5339d02 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.21.27"
+"1.0.21.28"
-- 
1.7.10.4