From: Chris Hanson <org/chris-hanson/cph>
Date: Thu, 8 Mar 2001 19:26:59 +0000 (+0000)
Subject: Implement LOAD-LIBRARY-OBJECT-FILE for loading primitives that are
X-Git-Tag: 20090517-FFI~2917
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5e3af089b0fc17e7ebc77c6dddd586422c03bf0f;p=mit-scheme.git

Implement LOAD-LIBRARY-OBJECT-FILE for loading primitives that are
implemented as dynamically-loaded shared libraries.
---

diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm
index fc52b3056..5a64e6a37 100644
--- a/v7/src/runtime/load.scm
+++ b/v7/src/runtime/load.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: load.scm,v 14.55 2000/01/10 03:35:36 cph Exp $
+$Id: load.scm,v 14.56 2001/03/08 19:26:56 cph Exp $
 
 Copyright (c) 1988-2000 Massachusetts Institute of Technology
 
@@ -43,6 +43,8 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
   (set! condition-type:not-loading
 	(make-condition-type 'NOT-LOADING condition-type:error '()
 	  "No file being loaded."))
+  (reset-loaded-object-files!)
+  (add-event-receiver! event:after-restart reset-loaded-object-files!)
   (initialize-command-line-parsers)
   (set! hook/process-command-line default/process-command-line)
   (add-event-receiver! event:after-restart process-command-line))
@@ -56,6 +58,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (define condition-type:not-loading)
 (define load/default-find-pathname-with-type)
 (define fasload/default-types)
+(define loaded-object-files)
 
 ;;; This is careful to do the minimum number of file existence probes
 ;;; before opening the input file.
@@ -273,6 +276,39 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 			   (nearest-repl/environment)
 			   environment)))
 
+(define (load-library-object-file name errors?)
+  (let ((pathname
+	 (merge-pathnames name
+			  (system-library-directory-pathname "lib"))))
+    (if (there-exists? loaded-object-files
+	  (lambda (pathname*)
+	    (pathname=? pathname pathname*)))
+	#t
+	(let ((pathname*
+	       (let ((find
+		      (lambda (type)
+			(let ((pathname (pathname-new-type pathname type)))
+			  (and (file-exists? pathname)
+			       pathname)))))
+		 (or (find "so")
+		     (find "sl")))))
+	  (cond ((not pathname*)
+		 (and errors?
+		      (error "No library object file of this name:" pathname)))
+		((ignore-errors (lambda () (load pathname*)))
+		 => (lambda (condition)
+		      (if errors?
+			  (signal-condition condition)
+			  condition)))
+		(else
+		 (set! loaded-object-files
+		       (cons pathname loaded-object-files))
+		 #t))))))
+
+(define (reset-loaded-object-files!)
+  (set! loaded-object-files '())
+  unspecific)
+
 (define (loading-message suppress-loading-message? pathname do-it)
   (if suppress-loading-message?
       (do-it)
diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 4cca60330..26bbd540a 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.360 2001/02/28 21:42:42 cph Exp $
+$Id: runtime.pkg,v 14.361 2001/03/08 19:26:59 cph Exp $
 
 Copyright (c) 1988-2001 Massachusetts Institute of Technology
 
@@ -1454,6 +1454,7 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 	  fasload/default-types
 	  load
 	  load-latest
+	  load-library-object-file
 	  load-noisily
 	  load-noisily?
 	  load/default-find-pathname-with-type