-#!@-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))
-
-\f
-;;;; 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 '()))
- ((assoc (car args) command-table)
- => (lambda (row)
- ((cadr row) (cdr args))))
- (else
- (show-help '())))))
-
-(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-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)
- (let ((dl display-line-error))
- (dl "Usage: ")
- (dl " " program-name " link - print libraries to link with")
- ;; Not yet implemented.
- ;; (dl " " program-name " main - generate initialization code")
- (dl " " program-name " info [VAR] - print Guile build directories")
- (dl " " program-name " --help - show usage info (this message)")
- (dl " " program-name " --help SUBCOMMAND - show help for SUBCOMMAND")
- (dl " " program-name " --version - show running version")))
-
-(define (show-version args)
- (display-line program-name " - Guile version " program-version))
-
-\f
-;;;; 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 (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 the")
- (dle "Guile library, and any other libraries it requires.")))
-
-
-
-(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)))
-
-\f
-;;;; The "main" subcommand
-
-;;; We haven't implemented this yet, because we don't have the
-;;; mechanisms in place to discover the installed static link
-;;; libraries. When we do implement this, remember to fix the message
-;;; in show-help-overview.
-(define (build-main args)
- (display-line-error program-name ": `main' subcommand not yet implemented"))
-
-(define (help-main)
- (let ((dle display-line-error))
- (dle "Usage: " program-name " main")
- (dle "This subcommand is not yet implemented.")))
-
-\f
-;;;; 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]"))))
-
-(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 ((dle display-line-error))
- (dle "Usage: " program-name " info [VAR]")
- (dle "Display the value of the Makefile variable VAR used when Guile")
- (dle "was built. If VAR is omitted, display all Makefile variables.")
- (dle "Use this command to find out where Guile was installed,")
- (dle "where it will look for Scheme code at run-time, and so on.")))
-
-
-\f
-;;;; trivial utilities
-
-(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))))))
-
-\f
-;;;; 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 show-help-overview)
- (list "--help" show-help show-help-overview)
- (list "link" build-link help-link)
- (list "main" build-main help-main)
- (list "info" build-info help-info)))
-
-
-
-\f
-;;; Local Variables:
-;;; mode: scheme
-;;; End:
HCoop / bpt / guile.git / commitdiff