Import Upstream version 5d6upstream/5d6

1 files changed, 81 insertions, 127 deletions

diff --git a/Link.scm b/Link.scm
index c34d56e..0bed48e 100644
--- a/Link.scm
+++ b/Link.scm
@@ -1,4 +1,4 @@
-;; Copyright (C) 1993, 1994, 1995, 1997, 1998 Free Software Foundation, Inc.
+;; Copyright (C) 1993, 1994, 1995, 1997, 1998, 2002 Free Software Foundation, Inc.
 ;;
 ;; This program is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
@@ -15,160 +15,114 @@
 ;; the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
 ;;
 ;; As a special exception, the Free Software Foundation gives permission
-;; for additional uses of the text contained in its release of GUILE.
+;; for additional uses of the text contained in its release of SCM.
 ;;
-;; The exception is that, if you link the GUILE library with other files
+;; The exception is that, if you link the SCM library with other files
 ;; to produce an executable, this does not by itself cause the
 ;; resulting executable to be covered by the GNU General Public License.
 ;; Your use of that executable is in no way restricted on account of
-;; linking the GUILE library code into it.
+;; linking the SCM library code into it.
 ;;
 ;; This exception does not however invalidate any other reasons why
 ;; the executable file might be covered by the GNU General Public License.
 ;;
 ;; This exception applies only to the code released by the
-;; Free Software Foundation under the name GUILE.  If you copy
+;; Free Software Foundation under the name SCM.  If you copy
 ;; code from other Free Software Foundation releases into a copy of
-;; GUILE, as the General Public License permits, the exception does
+;; SCM, as the General Public License permits, the exception does
 ;; not apply to the code that you add in this way.  To avoid misleading
 ;; anyone as to the status of such modified files, you must delete
 ;; this exception notice from them.
 ;;
-;; If you write modifications of your own for GUILE, it is your choice
+;; If you write modifications of your own for SCM, it is your choice
 ;; whether to permit this exception to apply to your modifications.
 ;; If you do not wish that, delete this exception notice.
 
-;;;; "Link.scm", Compiling and dynamic linking code for SCM.
+;;;; "Link.scm", Dynamic linking/loading code for SCM.
 ;;; Author: Aubrey Jaffer.
 
-;;; This is an unusual autoload because it should load either the
-;;; source or compiled version if present.
-(if (not (defined? hobbit))		;Autoload for hobbit
-    (define (hobbit . args)
-      (require 'hobbit)
-      (apply hobbit args)))
-
-(define (compile-file file . args)
-  (apply hobbit file args)
-  (load (in-vicinity (implementation-vicinity) "build"))
-  (build-from-whole-argv
-   (list "build" "-tdll"
-	 (string-append "--compiler-options=-I" (implementation-vicinity))
-	 "-c"
-	 (begin (require 'glob)
-		((filename:substitute?? (scheme-file-suffix) ".c") file))
-	 "-hsystem"
-	 )))
-
-(define link-named-scm
-  (let ((scm:object-suffix (case (software-type)
-			     ((MSDOS VMS) ".obj")
-			     (else ".o"))))
-    (lambda (name . modules)
-      (load (in-vicinity (implementation-vicinity) "build"))
-      (let* ((iv (implementation-vicinity))
-	     (oss (string-append scm:object-suffix " "))
-	     (command
-	      (append
-	       (list "build" "--type=exe" "-cscm.c" "-hsystem"
-		     ;; "-F" "compiled-closure" "inexact"
-		     (string-append "--linker-options=-L"
-				    (implementation-vicinity)))
-	       (map (lambda (n) (string-append "-iinit_" n)) modules)
-	       (list
-		(apply string-append
-		       "-j"
-		       (map (lambda (n)
-			      (string-append n oss)) modules))
-		"-o" name))))
-	(cond ((>= (verbose) 3)
-	       (write command) (newline)))
-	(build-from-whole-argv command)))))
-
-;;;; Dynamic linking/loading
-
 (cond
  ((defined? dyn:link)
-  (define link:modules '())
-  (define link:able-suffix
-    (cond ((provided? 'shl) ".sl")
-	  ((provided? 'sun-dl) ".so")
-	  ((provided? 'mac-dl) ".shlb")
-	  (else ".o")))
-  (define link:link
-    (lambda (file . libs)
-      (define oloadpath *load-pathname*)
-      (let* ((sl (string-length file))
-	     (lasl (string-length link:able-suffix))
-	     (fname (let loop ((i (- sl 1)))
-		      (cond ((negative? i) file)
-			    ((vicinity:suffix? (string-ref file i))
-			     (substring file (+ i 1) sl))
-			    (else (loop (- i 1))))))
-	     (nsl (string-length fname))
-	     (name (cond ((< nsl lasl) fname)
-			 ((string-ci=? (substring fname (- nsl lasl) nsl)
-				       link:able-suffix)
-			  (substring fname 0 (- nsl lasl)))
-			 (else fname)))
-	     (linkobj #f))
-	(set! *load-pathname* file)
-	(set! linkobj (assoc name link:modules))
-	(cond (linkobj (dyn:unlink (cdr linkobj))))
-	(if (and (provided? 'sun-dl)
-		 (> 3 (string-length file))
-		 (not (eqv? (string-ref file 0) '#\/)))
-	    (set! file (string-append "./" file)))
-	(set! linkobj (dyn:link file))
-	(for-each (lambda (lib)
-		    (cond ((dyn:link lib))
-			  (else (slib:error "couldn't link: " lib))))
-		  libs)
-	(cond ((not linkobj)
-	       (set! *load-pathname* oloadpath) #f)
-	      ((dyn:call
-		(string-append
-		 "init_" (list->string (map char-downcase (string->list name))))
-		linkobj)
-	       (set! link:modules (acons name linkobj link:modules))
-	       (set! *load-pathname* oloadpath) #t)
-	      (else
-	       (dyn:unlink linkobj)
-	       (set! *load-pathname* oloadpath) #f)))))))
+(define link:able-suffix
+  (cond ((provided? 'shl) ".sl")
+	((provided? 'sun-dl) ".so")
+	((provided? 'mac-dl) ".shlb")
+	(else ".o")))
+(define (file->init_name name)
+  (string-append
+   "init_"
+   (list->string
+    (map (lambda (chr) (if (eqv? #\- chr) #\_ chr))
+	 (map char-downcase (string->list name))))))
+(define link:link
+  (lambda (file . libs)
+    (define oloadpath *load-pathname*)
+    (let* ((sl (string-length file))
+	   (lasl (string-length link:able-suffix))
+	   (fname (let loop ((i (- sl 1)))
+		    (cond ((negative? i) file)
+			  ((vicinity:suffix? (string-ref file i))
+			   (substring file (+ i 1) sl))
+			  (else (loop (- i 1))))))
+	   (nsl (string-length fname))
+	   (name (cond ((< nsl lasl) fname)
+		       ((string-ci=? (substring fname (- nsl lasl) nsl)
+				     link:able-suffix)
+			(substring fname 0 (- nsl lasl)))
+		       (else fname)))
+	   (linkobj #f))
+      (set! *load-pathname* file)
+      (if (and (provided? 'sun-dl)
+	       (< 3 sl)
+	       (not (eqv? (string-ref file 0) '#\/)))
+	  (set! file (string-append "./" file)))
+      (set! linkobj (or (provided? 'sun-dl) (dyn:link file)))
+      (and linkobj
+	   (for-each (lambda (lib)
+		       (or (dyn:link lib) (slib:error "couldn't link: " lib)))
+		     libs))
+      (if (provided? 'sun-dl) (set! linkobj (dyn:link file)))
+      (cond ((not linkobj)
+	     (set! *load-pathname* oloadpath) #f)
+	    ((dyn:call (file->init_name name) linkobj)
+	     (set! *load-pathname* oloadpath) #t)
+	    (else
+	     (dyn:unlink linkobj)
+	     (set! *load-pathname* oloadpath) #f)))))))
 
 (cond
  ((defined? vms:dynamic-link-call)
-  (define link:able-suffix #f)
-  (define (link:link file)
-    (define dir "")
-    (define fil "")
-    (let loop ((i (- (string-length file) 1)))
-      (cond ((negative? i) (set! dir file))
-	    ((vicinity:suffix? (string-ref file i))
-	     (set! dir (substring file 0 (+ i 1)))
-	     (set! fil (substring file (+ i 1) (string-length file))))
-	    (else (loop (- i 1)))))
-    (vms:dynamic-link-call dir fil (string-append "init_" fil)))))
+(define link:able-suffix #f)
+(define (link:link file)
+  (define dir "")
+  (define fil "")
+  (let loop ((i (- (string-length file) 1)))
+    (cond ((negative? i) (set! dir file))
+	  ((vicinity:suffix? (string-ref file i))
+	   (set! dir (substring file 0 (+ i 1)))
+	   (set! fil (substring file (+ i 1) (string-length file))))
+	  (else (loop (- i 1)))))
+  (vms:dynamic-link-call dir fil (file->init_name fil)))))
 
 (cond
  ((provided? 'sun-dl)
   ;; These libraries are (deferred) linked in conversion to ".so"
-  (define (usr:lib lib) #f)
-  (define (x:lib lib) #f))
+(define (usr:lib lib) #f)
+(define (x:lib lib) #f))
  ((provided? 'shl)
-  (define (usr:lib lib)
-    (if (member lib '("c" "m"))
-	(string-append "/lib/lib" lib link:able-suffix)
-	(string-append "/usr/lib/lib" lib link:able-suffix)))
-  (define (x:lib lib) (string-append "/usr/X11R5/lib/lib"
-				     lib link:able-suffix)))
+(define (usr:lib lib)
+  (if (member lib '("c" "m"))
+      (string-append "/lib/lib" lib link:able-suffix)
+      (string-append "/usr/lib/lib" lib link:able-suffix)))
+(define (x:lib lib) (string-append "/usr/X11R5/lib/lib"
+				   lib link:able-suffix)))
  ((provided? 'dld:dyncm)
-  (define (usr:lib lib)
-    (or (and (member lib '("c" "m"))
-	     (let ((sa (string-append "/usr/lib/lib" lib ".sa")))
-	       (and (file-exists? sa) sa)))
-	(string-append "/usr/lib/lib" lib ".a")))
-  (define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa")))
+(define (usr:lib lib)
+  (or (and (member lib '("c" "m"))
+	   (let ((sa (string-append "/usr/lib/lib" lib ".sa")))
+	     (and (file-exists? sa) sa)))
+      (string-append "/usr/lib/lib" lib ".a")))
+(define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa")))
  ((provided? 'dld)
-  (define (usr:lib lib) (string-append "/usr/lib/lib" lib ".a"))
-  (define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa"))))
+(define (usr:lib lib) (string-append "/usr/lib/lib" lib ".a"))
+(define (x:lib lib) (string-append "/usr/X11/lib/lib" lib ".sa"))))