From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Wed, 2 Mar 2016 23:08:33 +0000 (-0700)
Subject: runtime/ffi: Add plugin-available?.  Eliminate free variable ref.
X-Git-Tag: mit-scheme-pucked-9.2.12~261^2~75^2~20
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=7532458053036eb5a5f6770279e3b36f3e70e185;p=mit-scheme.git

runtime/ffi: Add plugin-available?.  Eliminate free variable ref.
---

diff --git a/src/runtime/ffi.scm b/src/runtime/ffi.scm
index f0adc4b90..a242a86d6 100644
--- a/src/runtime/ffi.scm
+++ b/src/runtime/ffi.scm
@@ -245,7 +245,7 @@ USA.
       unspecific
       (let* ((library (%alien-function/library afunc))
 	     (name (%alien-function/name afunc))
-	     (pathname (dlopen-pathname library))
+	     (pathname (plugin-pathname library))
 	     (handle (or (find-dld-handle
 			  (lambda (h)
 			    (pathname=? pathname (dld-handle-pathname h))))
@@ -256,16 +256,20 @@ USA.
 	    (error:bad-range-argument afunc 'alien-function-cache!))
 	(set-%alien-function/band-id! afunc band-id))))
 
-(define (dlopen-pathname library)
-  (or (libtool-pathname library)
+(define (plugin-available? name)
+  (let ((path (ignore-errors (lambda () (plugin-pathname name)))))
+    (and (pathname? path)
+	 (file-loadable? path))))
+
+(define (plugin-pathname name)
+  (or (libtool-pathname name)
       (system-library-pathname
-       (pathname-new-type (string-append library"-shim")
-			  "so"))
-      (error "Could not find module:" library)))
+       (pathname-new-type (string-append name"-shim") "so"))
+      (error "Could not find plugin:" name)))
 
-(define (libtool-pathname library)
+(define (libtool-pathname name)
   (let ((la-pathname (system-library-pathname
-		      (pathname-new-type (string-append library"-shim")
+		      (pathname-new-type (string-append name"-shim")
 					 "la"))))
     (let ((dlname (libtool-dlname la-pathname))
 	  (dirname (directory-pathname la-pathname)))
@@ -580,7 +584,7 @@ USA.
 
 (define (generate-shim library #!optional prefix)
   (load-ffi-quietly)
-  (c-generate library prefix))
+  ((environment-lookup (->environment '(ffi)) 'c-generate) library prefix))
 
 (define (update-optiondb directory)
   (load-ffi-quietly)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 5337ebc29..8f0b7313a 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -3395,48 +3395,49 @@ USA.
   (parent (runtime))
   (files "ffi")
   (export ()
-	  make-alien
-	  copy-alien
-	  alien/ctype
-	  set-alien/ctype!
-	  c-cast
-	  alien?
-	  alien-null?
+	  alien-byte-increment
+	  alien-byte-increment!
+	  alien-function/name
+	  alien-function?
+	  alien-hash
 	  alien-null!
+	  alien-null?
 	  alien/address-string
-	  null-alien
+	  alien/ctype
 	  alien=?
-	  alien-hash
-	  copy-alien-address!
-	  alien-function?
-	  alien-function/name
-	  alien-byte-increment
-	  alien-byte-increment!
-	  error:not-alien
-	  guarantee-alien-function
-	  error:not-alien-function
-	  guarantee-alien
+	  alien?
+	  c-cast
+	  c-enum-name
+	  c-peek-bytes
 	  c-peek-cstring
 	  c-peek-cstring!
 	  c-peek-cstringp
 	  c-peek-cstringp!
-	  c-peek-bytes
+	  c-poke-bytes
 	  c-poke-pointer
 	  c-poke-pointer!
 	  c-poke-string
 	  c-poke-string!
-	  c-poke-bytes
-	  c-enum-name
 	  call-alien
+	  copy-alien
+	  copy-alien-address!
+	  de-register-c-callback
+	  error:not-alien
+	  error:not-alien-function
+	  free
+	  generate-shim
+	  guarantee-alien
+	  guarantee-alien-function
+	  make-alien
 	  make-alien-to-free
 	  malloc
-	  free
-	  register-c-callback
-	  de-register-c-callback
+	  null-alien
 	  outf-error
-	  generate-shim
-	  update-optiondb
-	  update-html-index)
+	  plugin-available?
+	  register-c-callback
+	  set-alien/ctype!
+	  update-html-index
+	  update-optiondb)	  
   (initialization (initialize-package!)))
 
 (define-package (runtime program-copier)