diff options
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")))) |