#!/usr/bin/guile \
-e "(scripts guile-config)" -s
!#
;;; guile-config --- utility for linking programs with Guile

;;	Copyright (C) 1998,2002,03,2004 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, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE 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.
;;
;; 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
;; code from other Free Software Foundation releases into a copy of
;; GUILE, 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
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Jim Blandy <jim@red-bean.com> --- September 1997
;;;	Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; * Usage: guile-config link
;;
;;   Print the linker command-line flags necessary to link against
;;   libguile, and any other libraries it requires.
;;
;; * Usage: guile-config compile
;;
;;   Print C compiler flags for compiling code that uses Guile.
;;   This includes any `-I' flags needed to find Guile's header files.
;;
;; * Usage: guile-config info [VAR]
;;
;;   Display the value of the Makefile variable VAR used when Guile
;;   was built.  If VAR is omitted, display all Makefile variables.
;;   Use this command to find out where Guile was installed,
;;   where it will look for Scheme code at run-time, and so on.
;;
;; * Usage; guile-config re-prefix-info [VAR]
;;
;;   Like "guile-config info" but wherever VAR's value has a prefix
;;   that matches the output of "guile-config info prefix", that
;;   substring is replaced with the literal "${prefix}".  (This does
;;   not apply when VAR is "prefix" to avoid tautology, obviously. :-)
;;
;; * Usage: guile-config scmconfig SYMBOL
;;
;;   Exit successfully if SYMBOL was defined in libguile/scmconfig.h
;;   (uninstalled header).  Do not display anything.
;;
;; * Usage: guile-config acsubst VAR
;;
;;   Display value of VAR if it was one of those AC_SUBSTituted
;;   during Guile build.  If VAR is not available, signal error.
;;   This command is equivalent to:
;;      guile-tools guile-config-data VAR
;;   with the addition of error checking.
;;
;;
;; * Usage from a Scheme program:
;;     (use-modules (scripts guile-config))
;;     (guile-config . args)       => string
;;     (guile-config/split . args) => list of strings
;;
;;   ARGS is one of the "commands" above, such as "info" or "compile",
;;   followed by an additional optional specifier.  Either element of
;;   ARGS can be a symbol or a string.  For example, here are two sets
;;   of equivalent invocations:
;;
;;     (guile-config 'info 'pkgdatadir)      (guile-config 'compile)
;;     (guile-config 'info "pkgdatadir")     (guile-config "compile")
;;     (guile-config "info" 'pkgdatadir)
;;     (guile-config "info" "pkgdatadir")
;;
;;   These procedures basically capture the output as if guile-config
;;   were invoked as a command from the shell.  The former discards
;;   the final newline.  The latter additionally discards whitespace,
;;   and always returns a list (sometimes of length 1).
;;
;;   Behavior is undefined for null ARGS or unrecognized commands.

;;; Code:

(define-module (scripts guile-config)
  #:use-module ((ice-9 gumm) #:select (eval-in-current-module-proc))
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:autoload (scripts split-string-no-nulls) (split-string-no-nulls)
  #:autoload (scripts guile-config-data) (guile-config-data)
  #:export (guile-config guile-config/split))

;;; vars

(define *commands* '(link compile info re-prefix-info scmconfig acsubst))

(define *me* "guile-config")

(define *e* (eval-in-current-module-proc))

;;; support

(define (errfmt fmt . args)
  (error (apply simple-format #f fmt args)))

(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))))))

(define (GBI key)
  (assq-ref %guile-build-info key))

(define (GCD key)
  (assq-ref guile-config-data key))

(define (look-up-info little-*me* conv args)
  (cond ((null? args)
         (for-each (lambda (pair)
                     (simple-format #t "~A = ~A\n"
                                    (car pair) (conv (car pair) (cdr pair))))
                   %guile-build-info))
        ((null? (cdr args))
         (let ((var (string->symbol (car args))))
           (simple-format #t "~A\n"
                          (or (conv var (GBI var))
                              (errfmt "~A ~A: no such var: ~A\n"
                                      *me* little-*me* var)))))
        (else
         (errfmt  "Usage: ~A ~A [VAR]\n" *me* little-*me*))))


;;; 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 (COMMAND:link args)

  ;; match "FOO/libBAR.a" and return substring "BAR", or #f
  (define (match-lib path)
    (let* ((base (basename path))
           (len (string-length base)))
      (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)))))

  (or (null? args)
      (errfmt "~A link: arguments to subcommand not yet implemented\n" *me*))

  (display-separated
   (cons
    ;; start w/ libguile and friends
    (simple-format #f "-L~A -lguile~A"
                   (GBI 'libdir)
                   (if (memq 'DYNAMIC_LINKING (GCD 'scmconfig))
                       " -lltdl"
                       "")
                   ;; add friends here.
                   )
    ;; continue with other LIBS
    (let loop ((libs (split-string-no-nulls (GBI 'LIBS))))
      (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)))))
            (else
             (cons (car libs) (loop (cdr libs))))))))
  (newline))


;;; the "compile" subcommand

(define (COMMAND:compile args)
  (or (null? args)
      (error (simple-format #f "~A compile: no arguments expected\n" *me*)))
  (simple-format #t "-I~A\n" (GBI 'includedir)))


;;; the "info" subcommand

(define (COMMAND:info args)
  (look-up-info "info" (lambda (key s) s) args))


;;; the "re-prefix-info" subcommand

(define (COMMAND:re-prefix-info args)
  (look-up-info "re-prefix-info"
                (let* ((prefix (GBI 'prefix))
                       (len (string-length prefix)))
                  (lambda (key s)       ; avoid tautological keys
                    (or (and (not (eq? key 'prefix))
                             (<= len (string-length s))
                             (string=? (substring s 0 len) prefix)
                             (simple-format #f "${prefix}~A" (substring s len)))
                        s)))
                args))


;;; the "scmconfig" subcommand

(define (COMMAND:scmconfig args)
  (cond ((= 1 (length args))
         (memq (string->symbol (car args))
               (GCD 'scmconfig)))
        (else
         (errfmt "Usage: ~A scmconfig SYMBOL\n" *me*))))


;;; the "acsubst" subcommand

(define (COMMAND:acsubst args)
  (cond ((= 1 (length args))
         (let ((var (string->symbol (car args))))
           (simple-format #t "~A\n"
                          (or (GCD var)
                              (errfmt "~A acsubst: no such var: ~A\n"
                                      *me* var)))))
        (else
         (errfmt "Usage: ~A acsubst VAR\n" *me*))))


;;; dispatch

(define (guile-config-main . args)
  (if (null? args)
      (error "no command specified")
      (let ((cmd (string->symbol (car args))))
        (cond ((memq cmd *commands*)
               (*e* `(,((symbol-prefix-proc 'COMMAND:) cmd) ',(cdr args))))
              (else (error "unknown command:" cmd))))))

(define (main args)
  (HVQC-MAIN args (lambda (args)
                    (apply guile-config-main (cdr args)))
             '(usage . commentary)
             '(package . "Guile")
             '(package . "Guile")))


;;; support for use from Scheme programs

(define (guile-config . args)
  (let ((ans (with-output-to-string
               (lambda ()
                 (apply guile-config-main
                        (map (lambda (x)
                               (cond ((string? x) x)
                                     ((symbol? x) (symbol->string x))
                                     (else (error "wrong type arg:" x))))
                             args))))))
    ;; discard final newline
    (substring ans 0 (1- (string-length ans)))))

(define (guile-config/split . args)
  (split-string-no-nulls
   (apply guile-config args)))

;;; guile-config ends here
