0.8.17.20:

[sbcl.git] / src / code / foreign-load.lisp

diff --git a/src/code/foreign-load.lisp b/src/code/foreign-load.lisp
index fae0fb4..d8723f2 100644 (file)
--- a/src/code/foreign-load.lisp
+++ b/src/code/foreign-load.lisp
@@ -39,6 +39,8 @@
   (handle system-area-pointer)
   (symbol c-string))
 
+(define-alien-variable undefined-alien-address unsigned-long)
+
 (defvar *runtime-dlhandle*)
 (defvar *shared-objects*)
 
@@ -48,12 +50,12 @@
   (when objp
     (dlclose-or-lose obj))
   (dlerror) ; clear errors
-  (let* ((file (when obj (shared-object-file obj)))
+  (let* ((file (and obj (shared-object-file obj)))
          (sap (dlopen file (logior rtld-global rtld-now))))
     (aver (or (not objp) file))
     (when (zerop (sap-int sap))
       (if objp
-          (setf (shared-object-sap obj) *runtime-dlhandle*)
+          (setf (shared-object-sap obj) nil)
           (setf *runtime-dlhandle* nil))
       (error "Could not open ~:[runtime~;~:*shared object ~S~]: ~A"
              obj (dlerror)))
@@ -96,17 +98,33 @@ SB-EXT:SAVE-LISP-AND-DIE for details."
       (setf *shared-objects* (append (remove obj *shared-objects*)
                                      (list obj)))
       #!+linkage-table
-      (when old
+      (when (or old (undefined-foreign-symbols))
         (update-linkage-table))
       (pathname filename))))
 
 (defun try-reopen-shared-object (obj)
-  (with-simple-restart (skip "~@<Skip this shared object and continue. ~
-                              References to foreign symbols in this ~
-                              shared object will fail with undefined ~
-                              consequences.~:>")
-    (dlopen-or-lose obj)
-    obj))
+  (declare (type shared-object obj))
+  (tagbody :dlopen
+     (restart-case
+        (dlopen-or-lose obj)
+       (continue ()
+        :report "Skip this shared object and continue."
+        (setf (shared-object-sap obj) nil))
+       (retry ()
+        :report "Retry loading this shared object."
+        (go :dlopen))
+       (load-other ()
+        :report "Specify an alternate shared object file to load."
+        (setf (shared-object-file obj)
+              (tagbody :query
+                 (format *query-io* "~&Enter pathname (evaluated):~%")
+                 (force-output *query-io*)
+                 (let ((pathname (ignore-errors (pathname (read *query-io*)))))
+                   (unless (pathnamep pathname)
+                     (format *query-io* "~&Error: invalid pathname.~%")
+                     (go :query))
+                   (unix-namestring pathname)))))))
+  obj)
 
 ;;; Open libraries in *SHARED-OBJECTS* and the runtime. Called during
 ;;; initialization. 
@@ -121,14 +139,33 @@ SB-EXT:SAVE-LISP-AND-DIE for details."
   (mapc #'dlclose-or-lose (reverse *shared-objects*))
   (dlclose-or-lose))
 
-(defun get-dynamic-foreign-symbol-address (symbol)
-  (dlerror) ; clear old errors
-  (let ((result (sap-int (dlsym *runtime-dlhandle* symbol)))
-        (err (dlerror)))
-    (if (or (not (zerop result)) (not err))
-        result
-        (dolist (obj *shared-objects*)
-          (setf result (sap-int (dlsym (shared-object-sap obj) symbol))
-                err (dlerror))
-          (when (or (not (zerop result)) (not err))
-            (return result))))))
+(let ((symbols ())
+      (undefineds ()))
+  (defun get-dynamic-foreign-symbol-address (symbol)
+    (dlerror)                          ; clear old errors
+    (unless *runtime-dlhandle*
+      (bug "Cannot resolve foreign symbol: lost *runtime-dlhandle*"))
+    (let* ((result (sap-int (dlsym *runtime-dlhandle* symbol)))
+           (err (dlerror))
+           (addr (if (or (not (zerop result)) (not err))
+                     result
+                     (dolist (obj *shared-objects*)
+                       (let ((sap (shared-object-sap obj)))
+                         (when sap
+                           (setf result (sap-int (dlsym sap symbol))
+                                 err (dlerror))
+                           (when (or (not (zerop result)) (not err))
+                             (return result))))))))
+      (cond  ((not addr)
+              (style-warn "Undefined alien: ~S" symbol)
+              (pushnew symbol undefineds :test #'equal)
+              (remove symbol symbols :test #'equal)
+              undefined-alien-address)
+             (addr
+              (pushnew symbol symbols :test #'equal)
+              (remove symbol undefineds :test #'equal)
+              addr))))
+  (defun dynamic-foreign-symbols ()
+    symbols)
+  (defun undefined-foreign-symbols ()
+    undefineds))