diff options
author | LaMont Jones <lamont@debian.org> | 2003-05-07 08:36:40 -0600 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:27 -0800 |
commit | e21d47d7813159bb71e0671df9b52ec0470c358d (patch) | |
tree | 3c7770ea846123c291f599044e9f234ac17616bb /Link.scm | |
parent | 8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693 (diff) | |
parent | deda2c0fd8689349fea2a900199a76ff7ecb319e (diff) | |
download | scm-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.scm | 208 |
1 files changed, 81 insertions, 127 deletions
@@ -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")))) |