diff options
Diffstat (limited to 'Link.scm')
| -rw-r--r-- | Link.scm | 80 |
1 files changed, 29 insertions, 51 deletions
@@ -1,18 +1,18 @@ -;; Copyright (C) 1993, 1994, 1995, 1997 Free Software Foundation, Inc. -;; +;; Copyright (C) 1993, 1994, 1995, 1997, 1998 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 ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. -;; +;; ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. -;; +;; ;; You should have received a copy of the GNU General Public License ;; along with this software; see the file COPYING. If not, write to -;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. +;; 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. @@ -36,29 +36,11 @@ ;; ;; If you write modifications of your own for GUILE, it is your choice ;; whether to permit this exception to apply to your modifications. -;; If you do not wish that, delete this exception notice. +;; If you do not wish that, delete this exception notice. ;;;; "Link.scm", Compiling and dynamic linking code for SCM. ;;; Author: Aubrey Jaffer. -(define cc:command - (let ((default "cc -c")) ;-O removed for HP-UX self-compile - (case (software-type) - ((unix) (if (memq 'sun-dl *features*) - "gcc -g -O -fpic -c" ; If you have problems change -fpic to - ; -fPIC (see GCC info pages). - default)) - (else default)))) - -(define link:command - (case (software-type) - (else "cc"))) - -(define scm:object-suffix - (case (software-type) - ((MSDOS VMS) ".OBJ") - (else ".o"))) - ;;; This is an unusual autoload because it should load either the ;;; source or compiled version if present. (if (not (defined? hobbit)) ;Autoload for hobbit @@ -74,30 +56,34 @@ (string-append "--compiler-options=-I" (implementation-vicinity)) "-c" (begin (require 'glob) - (replace-suffix file (scheme-file-suffix) ".c")) + ((filename:substitute?? (scheme-file-suffix) ".c") file)) "-hsystem" ))) -(define (link-named-scm name . modules) - (load (in-vicinity (implementation-vicinity) "build")) - (let* ((iv (implementation-vicinity)) - (oss (string-append scm:object-suffix " ")) - (command - (list "build" "--type=exe" "-cscm.c" "-hsystem" - (string-append "--linker-options=-L" (implementation-vicinity)) - (apply string-append - "-i" - (map (lambda (n) - (string-append "init_" n)) - modules)) +(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))) + "-o" name)))) + (cond ((>= (verbose) 3) + (write command) (newline))) + (build-from-whole-argv command))))) ;;;; Dynamic linking/loading @@ -114,17 +100,9 @@ (define oloadpath *load-pathname*) (let* ((sl (string-length file)) (lasl (string-length link:able-suffix)) - (*vicinity-suffix* - (case (software-type) - ((NOSVE) '(#\: #\.)) - ((AMIGA) '(#\: #\/)) - ((UNIX) '(#\/)) - ((VMS) '(#\: #\])) - ((MSDOS ATARIST OS/2) '(#\\)) - ((MACOS THINKC) '(#\:)))) (fname (let loop ((i (- sl 1))) (cond ((negative? i) file) - ((memv (string-ref file i) *vicinity-suffix*) + ((vicinity:suffix? (string-ref file i)) (substring file (+ i 1) sl)) (else (loop (- i 1)))))) (nsl (string-length fname)) @@ -166,7 +144,7 @@ (define fil "") (let loop ((i (- (string-length file) 1))) (cond ((negative? i) (set! dir file)) - ((memv (string-ref file i) '(#\: #\])) + ((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))))) |