#!/bin/sh
# aside from this initial boilerplate, this is actually -*- scheme -*- code
main='(module-ref (resolve-module '\''(guile-rpc compile)) '\'compile')'
exec ${GUILE-/usr/bin/guile} -L "/usr/share/guile/site/2.2" -l "$0"    \
         -c "(apply $main (command-line))" "$@"
!#
;;; GNU Guile-RPC --- A Scheme implementation of ONC RPC.
;;; Copyright (C) 2008, 2012, 2014  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 3 of the License, 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 program.  If not, see <http://www.gnu.org/licenses/>.


;;;
;;; Compile XDR/RPC specifications to Scheme code.
;;;

;; Tell Guile to not issue warnings about duplicate bindings.
(default-duplicate-binding-handler '(last))

(define-module (guile-rpc compile)
  :autoload   (rpc compiler)         (rpc-language->scheme-server
                                      rpc-language->scheme-client
                                      *compiler-options*)
  :autoload   (rpc compiler parser)  (rpc-language->sexp *parser-options*)
  :autoload   (rpc compiler lexer)   (*strip-%-comments?*)
  :autoload   (ice-9 pretty-print)   (pretty-print)
  :use-module (srfi srfi-1)
  :use-module (srfi srfi-34)
  :use-module (srfi srfi-37)
  :use-module (srfi srfi-39)
  :export (compile))


;;;
;;; Options.
;;;

(define %options
  (list (option '("help") #f #f (lambda args (show-help)))
        (option '("version") #f #f (lambda args (show-version)))
        (option '(#\x "xdr") #f #f
                (lambda (opt name arg result)
                  (cons 'xdr result)))
        (option '(#\C "constants") #f #f
                (lambda (opt name arg result)
                  (cons 'constants result)))
        (option '(#\c "client") #f #f
                (lambda (opt name arg result)
                  (cons 'client result)))
        (option '(#\s "server") #f #f
                (lambda (opt name arg result)
                  (cons 'server result)))
        (option '(#\S "strict") #f #f
                (lambda (opt name arg result)
                  (cons 'strict result)))
        (option '("intermediate") #f #f
                (lambda (opt name arg result)
                  (cons 'intermediate result)))))

(define (show-help)
  (format #t "Usage: grpc-compile [OPTIONS]~%")
  (format #t "Read XDR/RPC specifications from the standard input and emit~%")
  (format #t "corresponding Scheme definitions on the standard output.~%~%")
  (format #t "  --help         Show this help message~%")
  (format #t "  --version      Show program version~%~%")
  (format #t "  -x, --xdr      Compile XDR type definitions.~%")
  (format #t "  -C, --constants~%")
  (format #t "                 Compile XDR constant definitions.~%")
  (format #t "  -c, --client   Compile client RPC stubs.~%")
  (format #t "  -s, --server   Compile server RPC stubs.~%~%")
  (format #t "  -S, --strict   Use strict XDR compliance (RFC 4506).  The main~%")
  (format #t "                 differences are: `char' type not recognized, `%'~%")
  (format #t "                 comments not permitted, `unsigned' type not recognized,~%")
  (format #t "                 `struct' no authorized in type specifiers.~%")
  (format #t "      --intermediate~%")
  (format #t "                 Output the intermediate form produced by the parser.~%")
  (format #t "~%")
  (format #t "It is customary to use C preprocessor directives in XDR/RPC specifications.~%")
  (format #t "When that is the case, pipe the specification through \"cpp -P\" before~%")
  (format #t "feeding it to `grpc-compile'.~%~%")
  (format #t "Report bugs to <bug-guile-rpc@gnu.org>.~%")
  (exit 0))

(define (show-version)
  (format #t "grpc-compile (GNU Guile-RPC) 0.4
Copyright (C) 2014 Free Software Foundation, Inc.

License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
This is free software: you are free to change and redistribute it.
There is NO WARRANTY, to the extent permitted by law.~%")
  (exit 0))

(define (report-compiler-error c)
  (define (location->string loc)
    (if loc
        (format #f "<standard input>:~a:~a" (location-line loc)
                (location-column loc))
        "<unknown location>"))

  (define (error-message)
    (let ((loc (compiler-error:location c)))
      (string-append (location->string loc) ": "

                     (cond ((parser-error? c)
                            (let ((token (parser-error:token c)))
                              (string-append "parse error: unexpected token `"
                                             (if (symbol? token)
                                                 (symbol->string token)
                                                 token)
                                             "'")))
                           ((lexer-error? c)
                            "lexer error")
                           ((compiler-unknown-type-error? c)
                            (let ((t
                                   (compiler-unknown-type-error:type-name c)))
                              (string-append "unknown type `" t "'")))
                           ((compiler-unknown-constant-error? c)
                            (let ((c
                                   (compiler-unknown-constant-error:constant-name
                                    c)))
                              (string-append "unknown constant `" c "'")))
                           ((compiler-duplicate-identifier-error? c)
                            (let ((name
                                   (compiler-duplicate-identifier-error:name
                                    c))
                                  (prev-loc
                                   (compiler-duplicate-identifier-error:previous-location
                                    c)))
                              (string-append "duplicate identifier `" name "'"
                                             (if prev-loc
                                                 (string-append "\n"
                                                                (location->string
                                                                 prev-loc)
                                                                ": previous "
                                                                "definition "
                                                                "is here")
                                                 ""))))
                           (else
                            (format #f "unexpected error (~a)" c))))))

  (format (current-error-port) "~a~%" (error-message))
  (exit 1))

(define (with-error-catch thunk)
  (guard (c ((compiler-error? c)
             (report-compiler-error c)))
    (thunk)))


;;;
;;; The compiler.
;;;

(define (compile . args)
  (define %non-strict-parser-options
    ;; Parser options when in non-strict mode.
    '(allow-unsigned allow-struct-type-specifier
      allow-string-param-type-specifier))

  (define %non-strict-compiler-options
    ;; Compiler options when in non-strict mode.
    '())

  (let* ((opts   (args-fold (cdr args) %options
                            (lambda (opt name args result)
                              (format (current-error-port)
                                      "~a: unrecognized option~%"
                                      (if (string? name)
                                          (string-append "--" name)
                                          (string-append "-" (string name)))))
                            (lambda (operand result)
                              (format (current-error-port)
                                      "parameter `~a' ignored~%"
                                      operand)
                              result)
                            '()))
         (intermediate? (memq 'intermediate opts))
         (strict? (memq 'strict opts))
         (xdr?    (memq 'xdr opts))
         (consts? (memq 'constants opts))
         (input   `(,@(if strict?
                          '()
                          ;; RFC 4506 (and its predecessor RFC 1832) do *not*
                          ;; define the `char' type.  However, it is supported
                          ;; by most implementations and actually used in Sun's
                          ;; RPC specification files.  They are equivalent to
                          ;; `int', so we just typedef it.
                          '((define-type "char" "int")))

                    ,@(with-error-catch
                       (lambda ()
                         (parameterize ((*strip-%-comments?* (not strict?))
                                        (*parser-options*
                                         (if strict?
                                             '()
                                             %non-strict-parser-options))
                                        (*compiler-options*
                                         (if strict?
                                             '()
                                             %non-strict-compiler-options)))
                            (rpc-language->sexp (current-input-port))))))))

    (define consts+types
      (filter (lambda (exp)
                (or (eq? (car exp) 'define-constant)
                    (eq? (car exp) 'define-type)))
              input))

    (with-error-catch
     (lambda ()
       (and intermediate?
            (if (null? (lset-intersection eq?
                                          '(server client consts xdr constants)
                                          opts))
                (for-each pretty-print input)
                (begin
                  (format (current-error-port)
                          "`--intermediate' and code generation options are exclusive.~%")
                  (exit 1))))
       (and consts?
            (for-each pretty-print
                      (rpc-language->scheme-client consts+types #f #t)))
       (and xdr?
            (for-each pretty-print
                      (rpc-language->scheme-client consts+types #t #f)))

       (and (memq 'client opts)
            (for-each pretty-print
                      (rpc-language->scheme-client input #f #f)))
       (and (memq 'server opts)
            (for-each pretty-print
                      (rpc-language->scheme-server input #f #f)))))
    #t))
