scripts/compile

   1 #!/bin/sh
   2 # -*- scheme -*-
   3 exec ${GUILE-guile} -e '(@ (scripts compile) compile)' -s $0 "$@"
   4 !#
   5 ;;; Compile --- Command-line Guile Scheme compiler
   6
   7 ;; Copyright 2005,2008,2009 Free Software Foundation, Inc.
   8 ;;
   9 ;; This program is free software; you can redistribute it and/or
  10 ;; modify it under the terms of the GNU General Public License as
  11 ;; published by the Free Software Foundation; either version 2, or
  12 ;; (at your option) 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 GNU
  17 ;; 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., 51 Franklin Street, Fifth Floor,
  22 ;; Boston, MA 02110-1301 USA
  23
  24 ;;; Author: Ludovic Courtès <ludo@gnu.org>
  25 ;;; Author: Andy Wingo <wingo@pobox.com>
  26
  27 ;;; Commentary:
  28
  29 ;; Usage: compile [ARGS]
  30 ;;
  31 ;; PROGRAM does something.
  32 ;;
  33 ;; TODO: Write it!
  34
  35 ;;; Code:
  36
  37 (define-module (scripts compile)
  38   #:use-module ((system base compile) #:select (compile-file))
  39   #:use-module (srfi srfi-1)
  40   #:use-module (srfi srfi-13)
  41   #:use-module (srfi srfi-37)
  42   #:export (compile))
  43
  44 \f
  45 (define (fail . messages)
  46   (format (current-error-port)
  47           (string-concatenate `("error: " ,@messages "~%")))
  48   (exit 1))
  49
  50 (define %options
  51   ;; Specifications of the command-line options.
  52   (list (option '(#\h "help") #f #f
  53                 (lambda (opt name arg result)
  54                   (alist-cons 'help? #t result)))
  55
  56         (option '(#\L "load-path") #t #f
  57                 (lambda (opt name arg result)
  58                   (let ((load-path (assoc-ref result 'load-path)))
  59                     (alist-cons 'load-path (cons arg load-path)
  60                                 result))))
  61         (option '(#\o "output") #t #f
  62                 (lambda (opt name arg result)
  63                   (if (assoc-ref result 'output-file)
  64                       (fail "`-o' option cannot be specified more than once")
  65                       (alist-cons 'output-file arg result))))
  66
  67         (option '(#\O "optimize") #f #f
  68                 (lambda (opt name arg result)
  69                   (alist-cons 'optimize? #t result)))
  70         (option '(#\e "expand-only") #f #f
  71                 (lambda (opt name arg result)
  72                   (alist-cons 'expand-only? #t result)))
  73         (option '(#\t "translate-only") #f #f
  74                 (lambda (opt name arg result)
  75                   (alist-cons 'translate-only? #t result)))
  76         (option '(#\c "compile-only") #f #f
  77                 (lambda (opt name arg result)
  78                   (alist-cons 'compile-only? #t result)))))
  79
  80 (define (parse-args args)
  81   "Parse argument list @var{args} and return an alist with all the relevant
  82 options."
  83   (args-fold args %options
  84              (lambda (opt name arg result)
  85                (format (current-error-port) "~A: unrecognized option" opt)
  86                (exit 1))
  87              (lambda (file result)
  88                (let ((input-files (assoc-ref result 'input-files)))
  89                  (alist-cons 'input-files (cons file input-files)
  90                              result)))
  91
  92              ;; default option values
  93              '((input-files)
  94                (load-path))))
  95
  96 \f
  97 (define (compile args)
  98   (let* ((options         (parse-args (cdr args)))
  99          (help?           (assoc-ref options 'help?))
 100          (optimize?       (assoc-ref options 'optimize?))
 101          (expand-only?    (assoc-ref options 'expand-only?))
 102          (translate-only? (assoc-ref options 'translate-only?))
 103          (compile-only?   (assoc-ref options 'compile-only?))
 104          (input-files     (assoc-ref options 'input-files))
 105          (output-file     (assoc-ref options 'output-file))
 106          (load-path       (assoc-ref options 'load-path)))
 107     (if (or help? (null? input-files))
 108         (begin
 109           (format #t "Usage: compile [OPTION] FILE...
 110 Compile each Guile Scheme source file FILE into a Guile object.
 111
 112   -h, --help           print this help message
 113
 114   -L, --load-path=DIR  add DIR to the front of the module load path
 115   -o, --output=OFILE   write output to OFILE
 116
 117   -O, --optimize       turn on optimizations
 118   -e, --expand-only    only go through the code expansion stage
 119   -t, --translate-only stop after the translation to GHIL
 120   -c, --compile-only   stop after the compilation to GLIL
 121
 122 Report bugs to <guile-user@gnu.org>.~%")
 123           (exit 0)))
 124
 125     (set! %load-path (append load-path %load-path))
 126
 127     (let ((compile-opts (append (if optimize? '(#:O) '())
 128                                 (if expand-only? '(#:e) '())
 129                                 (if translate-only? '(#:t) '())
 130                                 (if compile-only? '(#:c) '()))))
 131       (if output-file
 132           (if (and (not (null? input-files))
 133                    (null? (cdr input-files)))
 134               (compile-file (car input-files) output-file)
 135               (fail "`-o' option can only be specified "
 136                     "when compiling a single file"))
 137           (for-each (lambda (file)
 138                       (apply compile-file file compile-opts))
 139                     input-files)))))
 140
 141 ;;; Local Variables:
 142 ;;; coding: latin-1
 143 ;;; End: