;;;
;;; gauche.package.compile - compile extensions
;;;
;;;   Copyright (c) 2005-2025  Shiro Kawai  <shiro@acm.org>
;;;
;;;   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.
;;;

;; gauche.package.compile kicks C compiler/linker to compile an
;; extension file.

(define-module gauche.package.compile
  (use scheme.list)
  (use gauche.package)
  (use gauche.package.util)
  (use gauche.config)
  (use gauche.cgen.cise)
  (use gauche.cgen.stub)
  (use gauche.cgen.precomp)
  (use file.util)
  (use srfi.13)
  (export gauche-package-compile-and-link
          gauche-package-compile
          gauche-package-link
          gauche-package-clean))
(select-module gauche.package.compile)

;; When we run external compiler from gosh in the build tree instead of
;; installed one, referenced include paths and library paths are different.
;; Our API automatically translates configured incdirs and libdirs
;; when we detect in-place execution.
;;
;; (*) This alternative directory used to be provided by the caller
;; with gauche-buiddir keyword arguemnt.  However, this depends on the
;; very specific situation and we know exactly what we need, so ther's
;; no point to bother the caller.  We keep the keyword argument for
;; the backward compatibility but ignore it.

(define-values [*top-srcdir* *top-builddir*]
  (cond-expand
   [gauche.in-place
    ;; Builddir can be derived from this file (NB: out-of-tree build
    ;; create a symlink of scm files in build tree].
    ;; Srcdir is recorded in the file ${top_builddir}/top_srcdir
    (let* ([builddir (sys-normalize-pathname
                      (build-path (sys-dirname (current-load-path))
                                  ".." ".." "..")
                      :canonicalize #t)]
           [srcdir (string-trim-both
                    (file->string (build-path builddir "top_srcdir")))])
      (unless (file-exists? (build-path srcdir "src" "gauche.h"))
        (warn "Unsure about top_srcdir ~s\n" srcdir))
      (unless (file-exists? (build-path builddir "src" "gauche" "config.h"))
        (warn "Unsure about top_builddir ~s\n" builddir))
      (values srcdir builddir))]
   [else (values #f #f)]))

(define CC       (gauche-config "--cc"))
(define CFLAGS   (gauche-config "--so-cflags"))
(define (INCDIR) (filter-dir "I" (gauche-config "--incdirs") "--sysincdir"))
(define (LIBDIR) (filter-dir "L" (gauche-config "--archdirs") "--sysarchdir"))
(define LIBS     (gauche-config "-l"))
(define OBJEXT   (gauche-config "--object-suffix"))
(define SOEXT    (gauche-config "--so-suffix"))
(define LDFLAGS  (gauche-config "--so-ldflags"))

;; Returns object file name
(define (gauche-package-compile file :key (output #f)
                                          (cppflags #f)
                                          (cflags   #f)
                                          (c++-mode #f)
                                          (cc #f)
                                          (srcdir #f)
                                          (gauche-builddir #f) ; dummy (*)
                                          (keep-c #f)
                                          (no-line #f)
                                          (sofile #f)
                                          (ld #f)      ; dummy
                                          (ldflags #f) ; dummy
                                          (libs #f)    ; dummy
                                          ((:dry-run dry?) #f)
                                          ((:verbose verb?) #f))
  (parameterize ([dry-run dry?]
                 [verbose-run verb?]
                 [cise-omit-source-line no-line])
    (define srcfile (build-path srcdir file))
    (define cppflags+ (string-join (cond-list
                                    [cppflags]
                                    [srcdir #"-I '~|srcdir|'"])
                                   " "))
    (rlet1 ofile (or output
                     (sys-basename (path-swap-extension file OBJEXT)))
      (unless (and (file-exists? ofile)
                   (file-mtime>? ofile srcfile))
        (cond
         [(equal? (path-extension file) "scm")
          (let ([cfile (path-swap-extension file (if c++-mode "cpp" "c"))]
                [sofile (or sofile
                            (rlet1 f (sys-basename (path-swap-extension file SOEXT))
                              (warn "DSO file name is not specified.  Assuming `~a'\n" f)))])
            (unwind-protect
                (begin (cgen-precompile srcfile :out.c cfile :dso-name sofile)
                       (do-compile (or cc CC) cfile ofile
                                   cppflags+ (or cflags "")))
              (unless keep-c (sys-unlink cfile))))]
         [(equal? (path-extension file) "stub") ;deprecated
          (let1 cfile (path-swap-extension file (if c++-mode "cpp" "c"))
            (unwind-protect
                (begin (cgen-genstub srcfile)
                       (do-compile (or cc CC) cfile ofile
                                   cppflags+ (or cflags "")))
              (unless keep-c (sys-unlink cfile))))]
         [else
          (do-compile (or cc CC) srcfile ofile
                      cppflags+ (or cflags ""))])))))

(define (do-compile cc cfile ofile cppflags cflags)
  (run #"~cc -c ~cppflags ~(INCDIR) ~cflags ~CFLAGS -o '~ofile' '~cfile'"))

(define (gauche-package-link sofile ofiles :key (ldflags #f)
                                                (libs #f)
                                                (ld #f)
                                                (srcdir #f)   ; dummy
                                                (gauche-builddir #f) ; dummy (*)
                                                (keep-c #f)   ; dummy
                                                (no-line #f)  ; dummy
                                                (output #f)   ; dummy
                                                (cppflags #f) ; dummy
                                                (cflags #f)   ; dummy
                                                (c++-mode #f) ; dummy
                                                (cc #f)       ; dummy
                                                ((:dry-run dry?) #f)
                                                ((:verbose verb?) #f))
  (parameterize ([dry-run dry?]
                 [verbose-run verb?])
    (unless (and (file-exists? sofile)
                 (every (cut file-mtime>? sofile <>) ofiles))
      (let1 all-ofiles (string-join (map (^f #"'~f'") ofiles) " ")
        (run #"~(or ld CC) ~(or ldflags \"\") ~(LIBDIR) ~LDFLAGS '~sofile' ~all-ofiles ~LIBS ~(or libs \"\")")))))

(define (gauche-package-compile-and-link module-name files . args)
  (let1 sofile (or (get-keyword :output args #f)
                   #"~|module-name|.~|SOEXT|")
    (parameterize ([dry-run (get-keyword :dry-run args #f)]
                   [verbose-run (get-keyword :verbose args #f)])
      (guard (e [else (sys-unlink sofile)
                      (raise e)])
        (let1 objs (map (lambda (src)
                          (cond
                           [(equal? (path-extension src) OBJEXT) src]
                           [else (apply gauche-package-compile src
                                        :sofile sofile
                                        (delete-keyword :output args))]))
                        files)
          (apply gauche-package-link sofile objs args)
          sofile)))))

(define (gauche-package-clean module-name files :key (output #f))
  (when module-name
    (sys-unlink #"~|module-name|.~|SOEXT|"))
  (when output
    (sys-unlink output))
  (dolist (f files)
    (when (not (equal? (path-extension f) OBJEXT))
      (sys-unlink (sys-basename (path-swap-extension f OBJEXT))))))

;;
;; Utilities for in-place execution
;;
(define (replace-dir path
                     orig-dir  ; (gauche-config "--sysincdir") etc.
                     new-dir)  ; can be #f
  (if-let1 hit (and new-dir (string-contains path orig-dir))
    (string-replace path new-dir hit (+ hit (string-length orig-dir)))
    path))

;; Adjust pathnames in INCDIR and LIBDIR
;;   If we're running compiler in-place during testing, we replace
;;   the paths 'gauche-config --incdir' or 'gauche-config --libdir' returns
;;   with the source tree directories.
(define (filter-dir flag olddirs dir-key)
  (define dirlist
    (string-split olddirs (cond-expand [gauche.os.windows ";"][else ":"])))
  (define orig-dir (gauche-config dir-key))
  (define new-dirs
    (cond [(not *top-builddir*) '()] ; no conversion
          [(equal? dir-key "--sysarchdir")
           ;; for linking, we only need this
           (list (build-path *top-builddir* "src"))]
          [else
           (cond-list [#t (build-path *top-builddir* "src")]
                      [(not (equal? *top-builddir* *top-srcdir*))
                       (build-path *top-srcdir* "src")]
                      [#t (build-path *top-srcdir* "gc" "include")])]))

  (define (convert-1 dir)
    (if (null? new-dirs)
      (list dir)
      (map (cut replace-dir dir orig-dir <>) new-dirs)))
  ;; Return "-I<path> -I<path> ..." or "-L<path> -L<path> ...".
  ;; We exclude nonexistent paths, for OSX complains about it.
  (string-join (map (^s #"'-~|flag|~|s|'")
                    ($ filter file-exists?
                       $ append-map convert-1 dirlist))
               " "))
