mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-08 22:32:26 +02:00
242 lines
7 KiB
Scheme
242 lines
7 KiB
Scheme
#!@-bindir-@/guile \
|
||
-e main -s
|
||
!#
|
||
;;;; guile-config --- utility for linking programs with Guile
|
||
;;;; Jim Blandy <jim@red-bean.com> --- September 1997
|
||
|
||
;;; TODO:
|
||
;;; * Add some plausible structure for returning the right exit status,
|
||
;;; just something that encourages people to do the correct thing.
|
||
;;; * Implement the static library support. This requires that
|
||
;;; some portion of the module system be done.
|
||
|
||
(use-modules (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
|
||
((null? args) (show-help '())
|
||
(quit 1))
|
||
((assoc (car args) command-table)
|
||
=> (lambda (row)
|
||
(set! subcommand-name (car args))
|
||
((cadr row) (cdr args))))
|
||
(else (show-help '())
|
||
(quit 1)))))
|
||
|
||
(define program-name #f)
|
||
(define subcommand-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 (basename path)))
|
||
|
||
(define (show-help args)
|
||
(cond
|
||
((null? args) (show-help-overview))
|
||
((assoc (car args) command-table)
|
||
=> (lambda (row) ((caddr row))))
|
||
(else
|
||
(show-help-overview))))
|
||
|
||
(define (show-help-overview)
|
||
(display-line-error "Usage: ")
|
||
(for-each (lambda (row) ((cadddr row)))
|
||
command-table))
|
||
|
||
(define (usage-help)
|
||
(let ((dle display-line-error)
|
||
(p program-name))
|
||
(dle " " p " --help - show usage info (this message)")
|
||
(dle " " p " --help SUBCOMMAND - show help for SUBCOMMAND")))
|
||
|
||
(define (show-version args)
|
||
(display-line-error program-name " - Guile version " program-version))
|
||
|
||
(define (help-version)
|
||
(let ((dle display-line-error))
|
||
(dle "Usage: " program-name " --version")
|
||
(dle "Show the version of this script. This is also the version of")
|
||
(dle "Guile this script was installed with.")))
|
||
|
||
(define (usage-version)
|
||
(display-line-error
|
||
" " program-name " --version - show installed script and Guile 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")))
|
||
|
||
;; If PATH has the form FOO/libBAR.a, return the substring
|
||
;; BAR, otherwise return #f.
|
||
(define (match-lib path)
|
||
(let* ((base (basename path))
|
||
(len (string-length base)))
|
||
(if (and (> len 5)
|
||
(string=? (make-shared-substring base 0 3) "lib")
|
||
(string=? (make-shared-substring base (- len 2)) ".a"))
|
||
(make-shared-substring base 3 (- len 2))
|
||
#f)))
|
||
|
||
(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".
|
||
((match-lib (car libs))
|
||
=> (lambda (bar)
|
||
(cons (string-append "-l" bar)
|
||
(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)))))))
|
||
|
||
;; Include libguile itself in the list, along with the
|
||
;; directory it was installed in.
|
||
(flags (cons (string-append "-L" (get-build-info 'libdir))
|
||
(cons "-lguile" flags))))
|
||
|
||
;; Display the flags, separated by spaces.
|
||
(display-separated flags)
|
||
(newline)))
|
||
|
||
(define (help-link)
|
||
(let ((dle display-line-error))
|
||
(dle "Usage: " program-name " link")
|
||
(dle "Print linker flags for building the `guile' executable.")
|
||
(dle "Print the linker command-line flags necessary to link against")
|
||
(dle "the Guile library, and any other libraries it requires.")))
|
||
|
||
(define (usage-link)
|
||
(display-line-error
|
||
" " program-name " link - print libraries to link with"))
|
||
|
||
|
||
|
||
;;;; The "compile" subcommand
|
||
|
||
(define (build-compile args)
|
||
(if (> (length args) 0)
|
||
(error
|
||
(string-append program-name
|
||
" compile: no arguments expected")))
|
||
(display-line "-I" (get-build-info 'includedir)))
|
||
|
||
(define (help-compile)
|
||
(let ((dle display-line-error))
|
||
(dle "Usage: " program-name " compile")
|
||
(dle "Print C compiler flags for compiling code that uses Guile.")
|
||
(dle "This includes any `-I' flags needed to find Guile's header files.")))
|
||
|
||
(define (usage-compile)
|
||
(display-line-error
|
||
" " program-name " compile - print C compiler flags to compile with"))
|
||
|
||
|
||
;;;; The "info" subcommand
|
||
|
||
(define (build-info args)
|
||
(cond
|
||
((null? args) (show-all-vars))
|
||
((null? (cdr args)) (show-var (car args)))
|
||
(else (display-line-error "Usage: " program-name " info [VAR]")
|
||
(quit 2))))
|
||
|
||
(define (show-all-vars)
|
||
(for-each (lambda (binding)
|
||
(display-line (car binding) " = " (cdr binding)))
|
||
%guile-build-info))
|
||
|
||
(define (show-var var)
|
||
(display (get-build-info (string->symbol var)))
|
||
(newline))
|
||
|
||
(define (help-info)
|
||
(let ((d display-line-error))
|
||
(d "Usage: " program-name " info [VAR]")
|
||
(d "Display the value of the Makefile variable VAR used when Guile")
|
||
(d "was built. If VAR is omitted, display all Makefile variables.")
|
||
(d "Use this command to find out where Guile was installed,")
|
||
(d "where it will look for Scheme code at run-time, and so on.")))
|
||
|
||
(define (usage-info)
|
||
(display-line-error
|
||
" " program-name " info [VAR] - print Guile build directories"))
|
||
|
||
|
||
;;;; trivial utilities
|
||
|
||
(define (get-build-info name)
|
||
(let ((val (assq name %guile-build-info)))
|
||
(if (not (pair? val))
|
||
(begin
|
||
(display-line-error
|
||
program-name " " subcommand-name ": no such build-info: " name)
|
||
(quit 2)))
|
||
(cdr val)))
|
||
|
||
(define (display-line . args)
|
||
(apply display-line-port (current-output-port) args))
|
||
|
||
(define (display-line-error . args)
|
||
(apply display-line-port (current-error-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))))))
|
||
|
||
|
||
;;;; the command table
|
||
|
||
;;; We define this down here, so Guile builds the list after all the
|
||
;;; functions have been defined.
|
||
(define command-table
|
||
(list
|
||
(list "--version" show-version help-version usage-version)
|
||
(list "--help" show-help show-help-overview usage-help)
|
||
(list "link" build-link help-link usage-link)
|
||
(list "compile" build-compile help-compile usage-compile)
|
||
(list "info" build-info help-info usage-info)))
|
||
|
||
|
||
;;; Local Variables:
|
||
;;; mode: scheme
|
||
;;; End:
|