summaryrefslogtreecommitdiffstats
path: root/Link.scm
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:26 -0800
commitdeda2c0fd8689349fea2a900199a76ff7ecb319e (patch)
treec9726d54a0806a9b0c75e6c82db8692aea0053cf /Link.scm
parent3278b75942bdbe706f7a0fba87729bb1e935b68b (diff)
downloadscm-deda2c0fd8689349fea2a900199a76ff7ecb319e.tar.gz
scm-deda2c0fd8689349fea2a900199a76ff7ecb319e.zip
Import Upstream version 5d6upstream/5d6
Diffstat (limited to 'Link.scm')
-rw-r--r--Link.scm208
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"))))