mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-04 14:20:26 +02:00
b8b1f32221
people build Guile-based applications. * Makefile.am, Makefile.in, build-guile.in: New files.
127 lines
3.6 KiB
Scheme
127 lines
3.6 KiB
Scheme
#!@-bindir-@/guile \
|
||
-e main -s
|
||
!#
|
||
;;;; build-guile --- utility for linking programs with Guile
|
||
;;;; Jim Blandy <jim@red-bean.com> --- September 1997
|
||
|
||
(use-modules (ice-9 regex)
|
||
(ice-9 string-fun))
|
||
|
||
|
||
;;;; main function, command-line processing
|
||
|
||
;;; The script's entry point.
|
||
(define (main args)
|
||
(set-program-name! (car args))
|
||
(let ((args (cdr args)))
|
||
(cond
|
||
((zero? (length args)) (show-usage))
|
||
((string=? (car args) "--help") (show-usage))
|
||
((string=? (car args) "--version") (show-version))
|
||
((string=? (car args) "link") (build-link (cdr args)))
|
||
((string=? (car args) "main") (build-main (cdr args)))
|
||
(else (show-usage)))))
|
||
|
||
(define program-name #f)
|
||
(define program-version "@-GUILE_VERSION-@")
|
||
|
||
;;; Given an executable path PATH, set program-name to something
|
||
;;; appropriate f or use in error messages (i.e., with leading
|
||
;;; directory names stripped).
|
||
(define (set-program-name! path)
|
||
(set! program-name
|
||
(cond
|
||
((string-match "/([^/]+)$" path)
|
||
=> (lambda (match) (match:substring match 1)))
|
||
(else path))))
|
||
|
||
(define (show-usage)
|
||
(let ((dl display-line))
|
||
(dl "Usage: ")
|
||
(dl " " program-name " link - print libraries to link with")
|
||
(dl " " program-name " main - generate initialization code")
|
||
(dl " " program-name " --help - show usage info (this message)")
|
||
(dl " " program-name " --version - show running version")))
|
||
|
||
(define (show-version)
|
||
(display-line program-name " - Guile version " program-version))
|
||
|
||
|
||
;;;; the "link" subcommand
|
||
|
||
;;; Write a set of linker flags to standard output to include the
|
||
;;; libraries that libguile needs to link against.
|
||
;;;
|
||
;;; In the long run, we want to derive these flags from Guile module
|
||
;;; declarations files that are installed along the load path. For
|
||
;;; now, we're just going to reach into Guile's configuration info and
|
||
;;; hack it out.
|
||
(define (build-link args)
|
||
(if (> (length args) 0)
|
||
(error
|
||
(string-append program-name
|
||
" link: arguments to subcommand not yet implemented")))
|
||
|
||
(let* ((flags
|
||
(let loop ((libs
|
||
;; Get the string of linker flags we used to build
|
||
;; Guile, and break it up into a list.
|
||
(separate-fields-discarding-char #\space
|
||
(get-build-info 'LIBS)
|
||
list)))
|
||
(cond
|
||
((null? libs) '())
|
||
|
||
;; Turn any "FOO/libBAR.a" elements into "-lBAR".
|
||
((string-match "^.*/lib([^./]+).a$" (car libs))
|
||
=> (lambda (match)
|
||
(cons (string-append "-l" (match:substring match 1))
|
||
(loop (cdr libs)))))
|
||
|
||
;; Remove any empty strings that may have seeped in there.
|
||
((string=? (car libs) "") (loop (cdr libs)))
|
||
|
||
(else (cons (car libs) (loop (cdr libs)))))))
|
||
|
||
;; Don't omit -lguile itself from the list of flags.
|
||
(flags (cons "-lguile" flags)))
|
||
|
||
;; Display the flags, separated by spaces.
|
||
(display-separated flags)
|
||
(newline)))
|
||
|
||
(define (get-build-info name)
|
||
(let ((val (assq name %guile-build-info)))
|
||
(or val (error "get-build-info: no such build info: " name))
|
||
(cdr val)))
|
||
|
||
|
||
;;;; The "main" subcommand
|
||
|
||
(define (build-main args)
|
||
(display-line-port (current-error-port)
|
||
program-name ": `main' subcommand not yet implemented"))
|
||
|
||
|
||
;;;; trivial utilities
|
||
|
||
(define (display-line . args)
|
||
(apply display-line-port (current-output-port) args))
|
||
|
||
(define (display-line-port port . args)
|
||
(for-each (lambda (arg) (display arg port))
|
||
args)
|
||
(newline))
|
||
|
||
(define (display-separated args)
|
||
(let loop ((args args))
|
||
(cond ((null? args))
|
||
((null? (cdr args)) (display (car args)))
|
||
(else (display (car args))
|
||
(display " ")
|
||
(loop (cdr args))))))
|
||
|
||
|
||
;;; Local Variables:
|
||
;;; mode: scheme
|
||
;;; End:
|