summaryrefslogtreecommitdiffstats
path: root/Link.scm
diff options
context:
space:
mode:
authorLaMont Jones <lamont@debian.org>2003-05-07 08:36:40 -0600
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commite21d47d7813159bb71e0671df9b52ec0470c358d (patch)
tree3c7770ea846123c291f599044e9f234ac17616bb /Link.scm
parent8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693 (diff)
parentdeda2c0fd8689349fea2a900199a76ff7ecb319e (diff)
downloadscm-e21d47d7813159bb71e0671df9b52ec0470c358d.tar.gz
scm-e21d47d7813159bb71e0671df9b52ec0470c358d.zip
Import Debian changes 5d6-3.2debian/5d6-3.2
scm (5d6-3.2) unstable; urgency=low * Fix hppa compile. Closes: #144062 scm (5d6-3.1) unstable; urgency=low * NMU with patch from James Troup, to fix FTBFS on sparc. Closes: #191171 scm (5d6-3) unstable; urgency=low * Add build depend on xlibs-dev (Closes: #148020) scm (5d6-2) unstable; urgency=low * Remove libregexx-dev from build-depends. * Change build to use ./scmlit rather than scmlit (should fix some build problems) (looks like alpha is mostly building) * New release (Closes: #140175) * Built with turtlegraphics last time (Closes: #58515) scm (5d6-1) unstable; urgency=low * New upstream. * Add xlib and turtlegr to requested list of features. (closes some bug) * Make clean actually clean most everything up. * Remove hacks renaming build to something else and just set build as a .PHONY target in debian/rules. * Add the turtlegr code. scm (5d5-1) unstable; urgency=low * New upstream * Has fixes for 64 bit archs. May fix alpha compile problem. Does fix (Closes: #140175) * Take out -O2 arg. scm (5d4-3) unstable; urgency=low * Don't link with regexx, but just use libc6's regular expression functions. * Define (terms) to output /usr/share/common-licenses/GPL (Closes: #119321) scm (5d4-2) unstable; urgency=low * Add texinfo to build depends (Closes: #107011) scm (5d4-1) unstable; urgency=low * New upstream release. * Move install-info --remove to prerm. scm (5d3-5) unstable; urgency=low * Move scm info files to section "The Algorithmic Language Scheme" to match up with guile. scm (5d3-4) unstable; urgency=low * Fix build depends (Closes: #76691) scm (5d3-3) unstable; urgency=low * Fix path in scm dhelp file. scm (5d3-2) unstable; urgency=low * Actually put the header files in the package. Oops. scm (5d3-1) unstable; urgency=low * New upstream. (Closes: #74761) * Make (terms) use new license location. * Make use libregexx rather than librx. * Fix build depends for above. * Using new regex lib seems to fix crash (Closes: #66787) * Consider adding scm-dev package with headers, but instead just add the headers to the scm package. (Closes: #70787) * Add doc-base support.
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"))))