#! /usr/bin/env gosh

;;; compile-r7rs - compile R7RS programs
;;;
;;;   Copyright (c) 2024  Antero Mejr  <mail@antr.me>
;;;
;;;   Redistribution and use in source and binary forms, with or without
;;;   modification, are permitted provided that the following conditions
;;;   are met:
;;;
;;;   1. Redistributions of source code must retain the above copyright
;;;      notice, this list of conditions and the following disclaimer.
;;;
;;;   2. Redistributions in binary form must reproduce the above copyright
;;;      notice, this list of conditions and the following disclaimer in the
;;;      documentation and/or other materials provided with the distribution.
;;;
;;;   3. Neither the name of the authors nor the names of its contributors
;;;      may be used to endorse or promote products derived from this
;;;      software without specific prior written permission.
;;;
;;;   THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;;   "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;;   LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;;   A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;;   OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;;   SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;;   TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;;   PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;;   LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;;   NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;;   SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

;; Similar to build-standalone, but with an SRFI 138-compliant interface.

(use gauche.cgen.standalone)
(use gauche.parseopt)
(use gauche.process)
(use util.match)
(use file.util)

;; Needs to return a list of .sld files relative to the supplied dir.
(define (find-slds dir)
  (let-values (((subdirs files) (directory-list2 dir :children? #t
                                                 :add-path? #f)))
    (let* ((slds (filter (lambda (path)
                           (let ((ext (path-extension path)))
                             (and ext (string=? "sld" ext))))
                         files))
           (sd-sld (apply append (map (lambda (sd)
                                        (map (lambda (sld)
                                               (build-path sd sld))
                                             (find-slds (build-path dir sd))))
                                      subdirs))))
      (append slds sd-sld))))

;; Needs to return a list of full paths to directories with sld files.
(define (subdirs-with-slds dir)
  (let-values (((subdirs files) (directory-list2 dir :children? #t
                                                 :add-path? #t)))
    (let* ((slds (filter (lambda (path)
                           (let ((ext (path-extension path)))
                             (and ext (string=? "sld" ext))))
                         files))
           (sd-sld (apply append (map subdirs-with-slds subdirs))))
      (if (null? slds)
          sd-sld
          (cons dir sd-sld)))))

(define (usage)
  (print "Usage: compile-r7rs [options...] [pathname]")
  (print)
  (print "Options:")
  (print (option-parser-help-string))
  (exit 1))

(define (main args)
  (and-let1 alt-compiler (sys-getenv "COMPILE_R7RS")
    (print #"compile-r7rs: Environment variable COMPILE_R7RS is set (~|alt-compiler|).")
    (print #"  We don't run it as specified in SRFI-138, for it may be confusing")
    (print #"  if the variable is inadvertently set.  If you want to run ~|alt-compiler|,")
    (print #"  invoke it directly."))
  (do-compile (cdr args)))

(define (do-compile args)
  (let-args args
      ([outfile "o=s{OUTFILE}" (cond-expand
                                [gauche.os.windows "a.exe"]
                                [else "a.out"])
                ? "Specify output file name.  When omitted, 'a.out' or 'a.exe'
                   is used, depending on the platform."]
       [incdirs "I*=s{DIR}"
                ? "Specify a search path of extra files (lib/library.scm ...)
                   to prepend if they're not relative to the current directory.
                   This option can be given multiple times."]
       [appenddirs "A*=s{DIR}"
                ? "Specify a search path of extra files (lib/library.scm ...)
                   to append if they're not relative to the current directory.
                   This option can be given multiple times."]
       [feature-ids "D*=y{NAME}"
                ? "Add {NAME} to the list of feature identifiers maintained
                   by the Scheme implementation for the purpose of executing
                   the program in the text file pathname.
                   This option can be given multiple times."]
       [else _ (usage)]
       . files)
    (match files
      [(script.scm)
       (let* ([dirs (append incdirs appenddirs)]
              [extras (fold-right (lambda (dir acc)
                                    (append acc (find-slds dir)))
                                  '() dirs)]
              [incdirs (fold-right (lambda (dir acc)
                                     (append acc (subdirs-with-slds dir)))
                                   '() dirs)])
         (build-standalone script.scm
                           :outfile outfile
                           :extra-files extras
                           :include-dirs incdirs
                           :feature-ids feature-ids))]
      [_ (usage)]))
  0)

;; Local variables:
;; mode: scheme
;; end:
