| 1 | #!@-bindir-@/guile \ |
| 2 | -e main -s |
| 3 | !# |
| 4 | ;;;; guile-config --- utility for linking programs with Guile |
| 5 | ;;;; Jim Blandy <jim@red-bean.com> --- September 1997 |
| 6 | ;;;; |
| 7 | ;;;; Copyright (C) 1998 Free Software Foundation, Inc. |
| 8 | ;;;; |
| 9 | ;;;; This program is free software; you can redistribute it and/or modify |
| 10 | ;;;; it under the terms of the GNU General Public License as published by |
| 11 | ;;;; the Free Software Foundation; either version 2, or (at your option) |
| 12 | ;;;; any later version. |
| 13 | ;;;; |
| 14 | ;;;; This program is distributed in the hope that it will be useful, |
| 15 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
| 16 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| 17 | ;;;; GNU General Public License for more details. |
| 18 | ;;;; |
| 19 | ;;;; You should have received a copy of the GNU General Public License |
| 20 | ;;;; along with this software; see the file COPYING. If not, write to |
| 21 | ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330, |
| 22 | ;;;; Boston, MA 02111-1307 USA |
| 23 | ;;;; |
| 24 | ;;;; As a special exception, the Free Software Foundation gives permission |
| 25 | ;;;; for additional uses of the text contained in its release of GUILE. |
| 26 | ;;;; |
| 27 | ;;;; The exception is that, if you link the GUILE library with other files |
| 28 | ;;;; to produce an executable, this does not by itself cause the |
| 29 | ;;;; resulting executable to be covered by the GNU General Public License. |
| 30 | ;;;; Your use of that executable is in no way restricted on account of |
| 31 | ;;;; linking the GUILE library code into it. |
| 32 | ;;;; |
| 33 | ;;;; This exception does not however invalidate any other reasons why |
| 34 | ;;;; the executable file might be covered by the GNU General Public License. |
| 35 | ;;;; |
| 36 | ;;;; This exception applies only to the code released by the |
| 37 | ;;;; Free Software Foundation under the name GUILE. If you copy |
| 38 | ;;;; code from other Free Software Foundation releases into a copy of |
| 39 | ;;;; GUILE, as the General Public License permits, the exception does |
| 40 | ;;;; not apply to the code that you add in this way. To avoid misleading |
| 41 | ;;;; anyone as to the status of such modified files, you must delete |
| 42 | ;;;; this exception notice from them. |
| 43 | ;;;; |
| 44 | ;;;; If you write modifications of your own for GUILE, it is your choice |
| 45 | ;;;; whether to permit this exception to apply to your modifications. |
| 46 | ;;;; If you do not wish that, delete this exception notice. |
| 47 | |
| 48 | ;;; TODO: |
| 49 | ;;; * Add some plausible structure for returning the right exit status, |
| 50 | ;;; just something that encourages people to do the correct thing. |
| 51 | ;;; * Implement the static library support. This requires that |
| 52 | ;;; some portion of the module system be done. |
| 53 | |
| 54 | (use-modules (ice-9 string-fun)) |
| 55 | |
| 56 | \f |
| 57 | ;;;; main function, command-line processing |
| 58 | |
| 59 | ;;; The script's entry point. |
| 60 | (define (main args) |
| 61 | (set-program-name! (car args)) |
| 62 | (let ((args (cdr args))) |
| 63 | (cond |
| 64 | ((null? args) (show-help '()) |
| 65 | (quit 1)) |
| 66 | ((assoc (car args) command-table) |
| 67 | => (lambda (row) |
| 68 | (set! subcommand-name (car args)) |
| 69 | ((cadr row) (cdr args)))) |
| 70 | (else (show-help '()) |
| 71 | (quit 1))))) |
| 72 | |
| 73 | (define program-name #f) |
| 74 | (define subcommand-name #f) |
| 75 | (define program-version "@-GUILE_VERSION-@") |
| 76 | |
| 77 | ;;; Given an executable path PATH, set program-name to something |
| 78 | ;;; appropriate f or use in error messages (i.e., with leading |
| 79 | ;;; directory names stripped). |
| 80 | (define (set-program-name! path) |
| 81 | (set! program-name (basename path))) |
| 82 | |
| 83 | (define (show-help args) |
| 84 | (cond |
| 85 | ((null? args) (show-help-overview)) |
| 86 | ((assoc (car args) command-table) |
| 87 | => (lambda (row) ((caddr row)))) |
| 88 | (else |
| 89 | (show-help-overview)))) |
| 90 | |
| 91 | (define (show-help-overview) |
| 92 | (display-line-error "Usage: ") |
| 93 | (for-each (lambda (row) ((cadddr row))) |
| 94 | command-table)) |
| 95 | |
| 96 | (define (usage-help) |
| 97 | (let ((dle display-line-error) |
| 98 | (p program-name)) |
| 99 | (dle " " p " --help - show usage info (this message)") |
| 100 | (dle " " p " --help SUBCOMMAND - show help for SUBCOMMAND"))) |
| 101 | |
| 102 | (define (show-version args) |
| 103 | (display-line-error program-name " - Guile version " program-version)) |
| 104 | |
| 105 | (define (help-version) |
| 106 | (let ((dle display-line-error)) |
| 107 | (dle "Usage: " program-name " --version") |
| 108 | (dle "Show the version of this script. This is also the version of") |
| 109 | (dle "Guile this script was installed with."))) |
| 110 | |
| 111 | (define (usage-version) |
| 112 | (display-line-error |
| 113 | " " program-name " --version - show installed script and Guile version")) |
| 114 | |
| 115 | \f |
| 116 | ;;;; the "link" subcommand |
| 117 | |
| 118 | ;;; Write a set of linker flags to standard output to include the |
| 119 | ;;; libraries that libguile needs to link against. |
| 120 | ;;; |
| 121 | ;;; In the long run, we want to derive these flags from Guile module |
| 122 | ;;; declarations files that are installed along the load path. For |
| 123 | ;;; now, we're just going to reach into Guile's configuration info and |
| 124 | ;;; hack it out. |
| 125 | (define (build-link args) |
| 126 | (if (> (length args) 0) |
| 127 | (error |
| 128 | (string-append program-name |
| 129 | " link: arguments to subcommand not yet implemented"))) |
| 130 | |
| 131 | ;; If PATH has the form FOO/libBAR.a, return the substring |
| 132 | ;; BAR, otherwise return #f. |
| 133 | (define (match-lib path) |
| 134 | (let* ((base (basename path)) |
| 135 | (len (string-length base))) |
| 136 | (if (and (> len 5) |
| 137 | (string=? (make-shared-substring base 0 3) "lib") |
| 138 | (string=? (make-shared-substring base (- len 2)) ".a")) |
| 139 | (make-shared-substring base 3 (- len 2)) |
| 140 | #f))) |
| 141 | |
| 142 | (let* ((flags |
| 143 | (let loop ((libs |
| 144 | ;; Get the string of linker flags we used to build |
| 145 | ;; Guile, and break it up into a list. |
| 146 | (separate-fields-discarding-char #\space |
| 147 | (get-build-info 'LIBS) |
| 148 | list))) |
| 149 | |
| 150 | (cond |
| 151 | ((null? libs) '()) |
| 152 | |
| 153 | ;; Turn any "FOO/libBAR.a" elements into "-lBAR". |
| 154 | ((match-lib (car libs)) |
| 155 | => (lambda (bar) |
| 156 | (cons (string-append "-l" bar) |
| 157 | (loop (cdr libs))))) |
| 158 | |
| 159 | ;; Remove any empty strings that may have seeped in there. |
| 160 | ((string=? (car libs) "") (loop (cdr libs))) |
| 161 | |
| 162 | (else (cons (car libs) (loop (cdr libs))))))) |
| 163 | |
| 164 | ;; Include libguile itself in the list, along with the |
| 165 | ;; directory it was installed in. |
| 166 | (flags (cons (string-append "-L" (get-build-info 'libdir)) |
| 167 | (cons "-lguile" flags)))) |
| 168 | |
| 169 | ;; Display the flags, separated by spaces. |
| 170 | (display-separated flags) |
| 171 | (newline))) |
| 172 | |
| 173 | (define (help-link) |
| 174 | (let ((dle display-line-error)) |
| 175 | (dle "Usage: " program-name " link") |
| 176 | (dle "Print linker flags for building the `guile' executable.") |
| 177 | (dle "Print the linker command-line flags necessary to link against") |
| 178 | (dle "the Guile library, and any other libraries it requires."))) |
| 179 | |
| 180 | (define (usage-link) |
| 181 | (display-line-error |
| 182 | " " program-name " link - print libraries to link with")) |
| 183 | |
| 184 | |
| 185 | \f |
| 186 | ;;;; The "compile" subcommand |
| 187 | |
| 188 | (define (build-compile args) |
| 189 | (if (> (length args) 0) |
| 190 | (error |
| 191 | (string-append program-name |
| 192 | " compile: no arguments expected"))) |
| 193 | (display-line "-I" (get-build-info 'includedir))) |
| 194 | |
| 195 | (define (help-compile) |
| 196 | (let ((dle display-line-error)) |
| 197 | (dle "Usage: " program-name " compile") |
| 198 | (dle "Print C compiler flags for compiling code that uses Guile.") |
| 199 | (dle "This includes any `-I' flags needed to find Guile's header files."))) |
| 200 | |
| 201 | (define (usage-compile) |
| 202 | (display-line-error |
| 203 | " " program-name " compile - print C compiler flags to compile with")) |
| 204 | |
| 205 | \f |
| 206 | ;;;; The "info" subcommand |
| 207 | |
| 208 | (define (build-info args) |
| 209 | (cond |
| 210 | ((null? args) (show-all-vars)) |
| 211 | ((null? (cdr args)) (show-var (car args))) |
| 212 | (else (display-line-error "Usage: " program-name " info [VAR]") |
| 213 | (quit 2)))) |
| 214 | |
| 215 | (define (show-all-vars) |
| 216 | (for-each (lambda (binding) |
| 217 | (display-line (car binding) " = " (cdr binding))) |
| 218 | %guile-build-info)) |
| 219 | |
| 220 | (define (show-var var) |
| 221 | (display (get-build-info (string->symbol var))) |
| 222 | (newline)) |
| 223 | |
| 224 | (define (help-info) |
| 225 | (let ((d display-line-error)) |
| 226 | (d "Usage: " program-name " info [VAR]") |
| 227 | (d "Display the value of the Makefile variable VAR used when Guile") |
| 228 | (d "was built. If VAR is omitted, display all Makefile variables.") |
| 229 | (d "Use this command to find out where Guile was installed,") |
| 230 | (d "where it will look for Scheme code at run-time, and so on."))) |
| 231 | |
| 232 | (define (usage-info) |
| 233 | (display-line-error |
| 234 | " " program-name " info [VAR] - print Guile build directories")) |
| 235 | |
| 236 | \f |
| 237 | ;;;; trivial utilities |
| 238 | |
| 239 | (define (get-build-info name) |
| 240 | (let ((val (assq name %guile-build-info))) |
| 241 | (if (not (pair? val)) |
| 242 | (begin |
| 243 | (display-line-error |
| 244 | program-name " " subcommand-name ": no such build-info: " name) |
| 245 | (quit 2))) |
| 246 | (cdr val))) |
| 247 | |
| 248 | (define (display-line . args) |
| 249 | (apply display-line-port (current-output-port) args)) |
| 250 | |
| 251 | (define (display-line-error . args) |
| 252 | (apply display-line-port (current-error-port) args)) |
| 253 | |
| 254 | (define (display-line-port port . args) |
| 255 | (for-each (lambda (arg) (display arg port)) |
| 256 | args) |
| 257 | (newline)) |
| 258 | |
| 259 | (define (display-separated args) |
| 260 | (let loop ((args args)) |
| 261 | (cond ((null? args)) |
| 262 | ((null? (cdr args)) (display (car args))) |
| 263 | (else (display (car args)) |
| 264 | (display " ") |
| 265 | (loop (cdr args)))))) |
| 266 | |
| 267 | \f |
| 268 | ;;;; the command table |
| 269 | |
| 270 | ;;; We define this down here, so Guile builds the list after all the |
| 271 | ;;; functions have been defined. |
| 272 | (define command-table |
| 273 | (list |
| 274 | (list "--version" show-version help-version usage-version) |
| 275 | (list "--help" show-help show-help-overview usage-help) |
| 276 | (list "link" build-link help-link usage-link) |
| 277 | (list "compile" build-compile help-compile usage-compile) |
| 278 | (list "info" build-info help-info usage-info))) |
| 279 | |
| 280 | \f |
| 281 | ;;; Local Variables: |
| 282 | ;;; mode: scheme |
| 283 | ;;; End: |