module/scripts/compile.scm

   1 ;;; Compile --- Command-line Guile Scheme compiler
   2
   3 ;; Copyright 2005,2008,2009 Free Software Foundation, Inc.
   4 ;;
   5 ;; This program is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU General Public License as
   7 ;; published by the Free Software Foundation; either version 2, or
   8 ;; (at your option) any later version.
   9 ;;
  10 ;; This program is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU General Public License
  16 ;; along with this software; see the file COPYING.  If not, write to
  17 ;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
  18 ;; Boston, MA 02110-1301 USA
  19
  20 ;;; Author: Ludovic Courtès <ludo@gnu.org>
  21 ;;; Author: Andy Wingo <wingo@pobox.com>
  22
  23 ;;; Commentary:
  24
  25 ;; Usage: compile [ARGS]
  26 ;;
  27 ;; A command-line interface to the Guile compiler.
  28
  29 ;;; Code:
  30
  31 (define-module (scripts compile)
  32   #:use-module ((system base compile) #:select (compile-file))
  33   #:use-module (srfi srfi-1)
  34   #:use-module (srfi srfi-13)
  35   #:use-module (srfi srfi-37)
  36   #:export (compile))
  37
  38 \f
  39 (define (fail . messages)
  40   (format (current-error-port)
  41           (string-concatenate `("error: " ,@messages "~%")))
  42   (exit 1))
  43
  44 (define %options
  45   ;; Specifications of the command-line options.
  46   (list (option '(#\h "help") #f #f
  47                 (lambda (opt name arg result)
  48                   (alist-cons 'help? #t result)))
  49
  50         (option '(#\L "load-path") #t #f
  51                 (lambda (opt name arg result)
  52                   (let ((load-path (assoc-ref result 'load-path)))
  53                     (alist-cons 'load-path (cons arg load-path)
  54                                 result))))
  55         (option '(#\o "output") #t #f
  56                 (lambda (opt name arg result)
  57                   (if (assoc-ref result 'output-file)
  58                       (fail "`-o' option cannot be specified more than once")
  59                       (alist-cons 'output-file arg result))))
  60
  61         (option '(#\O "optimize") #f #f
  62                 (lambda (opt name arg result)
  63                   (alist-cons 'optimize? #t result)))
  64         (option '(#\f "from") #t #f
  65                 (lambda (opt name arg result)
  66                   (if (assoc-ref result 'from)
  67                       (fail "`--from' option cannot be specified more than once")
  68                       (alist-cons 'from (string->symbol arg) result))))
  69         (option '(#\t "to") #t #f
  70                 (lambda (opt name arg result)
  71                   (if (assoc-ref result 'to)
  72                       (fail "`--to' option cannot be specified more than once")
  73                       (alist-cons 'to (string->symbol arg) result))))))
  74
  75 (define (parse-args args)
  76   "Parse argument list @var{args} and return an alist with all the relevant
  77 options."
  78   (args-fold args %options
  79              (lambda (opt name arg result)
  80                (format (current-error-port) "~A: unrecognized option" opt)
  81                (exit 1))
  82              (lambda (file result)
  83                (let ((input-files (assoc-ref result 'input-files)))
  84                  (alist-cons 'input-files (cons file input-files)
  85                              result)))
  86
  87              ;; default option values
  88              '((input-files)
  89                (load-path))))
  90
  91 \f
  92 (define (compile args)
  93   (let* ((options         (parse-args (cdr args)))
  94          (help?           (assoc-ref options 'help?))
  95          (compile-opts    (if (assoc-ref options 'optimize?) '(#:O) '()))
  96          (from            (or (assoc-ref options 'from) 'scheme))
  97          (to              (or (assoc-ref options 'to) 'objcode))
  98          (input-files     (assoc-ref options 'input-files))
  99          (output-file     (assoc-ref options 'output-file))
 100          (load-path       (assoc-ref options 'load-path)))
 101     (if (or help? (null? input-files))
 102         (begin
 103           (format #t "Usage: compile [OPTION] FILE...
 104 Compile each Guile source file FILE into a Guile object.
 105
 106   -h, --help           print this help message
 107
 108   -L, --load-path=DIR  add DIR to the front of the module load path
 109   -o, --output=OFILE   write output to OFILE
 110
 111   -f, --from=LANG      specify a source language other than `scheme'
 112   -t, --to=LANG        specify a target language other than `objcode'
 113
 114 Report bugs to <guile-user@gnu.org>.~%")
 115           (exit 0)))
 116
 117     (set! %load-path (append load-path %load-path))
 118
 119     (if (and output-file
 120              (or (null? input-files)
 121                  (not (null? (cdr input-files)))))
 122         (fail "`-o' option can only be specified "
 123               "when compiling a single file"))
 124
 125     (for-each (lambda (file)
 126                 (format #t "wrote `~A'\n"
 127                         (compile-file file
 128                                       #:output-file output-file
 129                                       #:from from
 130                                       #:to to
 131                                       #:opts compile-opts)))
 132               input-files)))
 133
 134 (define main compile)
 135
 136 ;;; Local Variables:
 137 ;;; coding: latin-1
 138 ;;; End: