;;;;
;;;; compfile.stk       -- STklos File Compiler
;;;;
;;;; Copyright © 2001-2024 Erick Gallesio <eg@stklos.net>
;;;;
;;;;
;;;; 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 2 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, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
;;;;           Author: Erick Gallesio [eg@unice.fr]
;;;;    Creation date: 17-Mar-2001 12:11 (eg)
;;;;


; modules seen in a file (used by compile-file)
(define *file-module-list* '())

(define (file-module-list-reset!)
  (set! *file-module-list* '()))

(define add-file-module-list!
  (let ((stklos (find-module 'stklos)))
    (lambda (mod)
      (unless (or (eq? mod stklos) (memq mod *file-module-list*))
        (set! *file-module-list* (cons mod *file-module-list*))))))

(define (file-module-list-expanders)
  ;; Build the list of all exported macros of the modules(s) in
  ;; the current file processed by current compile-file
  (apply append
         (map (lambda (mod)
                (let Loop ((lst (%module-exports mod))
                           (res '()))
                  (if (null? lst)
                      res
                      (let* ((symb (caar lst))
                             (val  (symbol-value* symb mod #f)))
                        ;; XXXX (%debug "symbol ~S syntax? ~S" symb (%syntax? val))
                        (Loop (cdr lst)
                              (if (%syntax? val)
                                  (cons (list (car lst)
                                              (module-name mod)
                                              (%syntax-source val))
                                        res)
                                  res))))))
              *file-module-list*)))

#|
<doc EXT compile-file
 * (compile-file input output)
 * (compile-file input output #:prepend cmds #:case-sensitive cs)
 *
 * Compiles the file whose name is |input| into a bytecode executable
 * whose name is |output| (if |compile-file| fails, |output| file is
 * deleted).
 *
 * This command accepts two optional keywords:
 *
 *  * |\#:prepend| :  it must be a list of  expressions, which will be
 *    compiled before the rest of the input  file. This can be used
 *    to define variables that the compiled program  will use (but it
 *    does not affect the compiler itself).
 *
 *  * |\#:case-sensitive| : it tells if the compiler reads symbols in
 *    case sensitive mode (as {{rseven}}) or not not (as {{rfive}}).
 *    By default the compiler is in case sensitive mode.
 *
 * This procedure will not set the executable bit on the generated file.
doc>
|#

(define (compile-file input output :key (prepend '() has-prepend?)
                                        (case-sensitive #t))

  (define (compute-file-information initial-globals)
    (let ((globs (let loop ((lst (compiler-known-globals))
                            (res '()))
                   (cond
                     ((null? lst)
                      res)
                     ((memv (car lst) initial-globals)
                      (loop (cdr lst) res))
                     (else
                      (loop (cdr lst) (cons (car lst)
                                            res)))))))
      ;; Return information
      (list :version   (version)
            :globals   globs
            :macros    (file-module-list-expanders))))

  (define (do-compile out)
    (let ((globs    (compiler-known-globals))
          (tm       (clock))
          (copts    (compiler:warn-use-undefined-postpone)))

      ;; Clear the list containing  macros sources
      (file-module-list-reset!)

      ;; Defer warning til the end of the compilation of file
                                        ;(compiler:warn-use-undefined-postpone #t)

      (fluid-let ((*code-instr* '())
                  (*code-constants* '())
                  (*compiling-file* #t))

        ;; SRFI 138, -D option:
        (when has-prepend?
          (unless (list? prepend)
            (error 'compile-file "prepend should be a list: ~S" prepend))
          ;; whatever the list is, if we wrap it in a BEGIN form,
          ;; it will be compiled sequentially:
          (let ((exprs (cons 'begin prepend)))
            (compile exprs #f exprs #f)))

        ;; Read the source file
        (%include-file input case-sensitive)
        (emit 'END-OF-CODE)

        ;; Write the header
        (format out "#!/usr/bin/env stklos\n")
        (format out "; A -*- Scheme -*- generated file *DO NOT EDIT**\n")
        (format out "STklos ~S\n" (compute-file-information globs))

        (let ((code (assemble (reverse! *code-instr*))))
          (when (compiler:show-assembly-code)
            ;;Write the assembly code and code vector
            (format out "\n#|\n")
            (disassemble-code code out)
            (format out "\n~S\n|\#\n" code))

          ;; Write new constants as a vector
          (format out "#~S\n" *code-constants*)

          ;; Write byte-code
          (%dump-code out code))

        ;; Close file
        (close-output-port out))

      ;; Show undefined symbols
      (compiler-show-undefined-symbols)

      ;; Display time used to compile file
      (when (and (interactive-port? (current-input-port))
                 (compiler:time-display))
        (format #t "Compilation time ~S ms\n" (exact (round (- (clock) tm)))))

      ;; Restore Compiler flags
      (compiler:warn-use-undefined-postpone copts)))

  ;; ----------------------------------------------------------------------
  ;; Make the compilation in a temporary file in output's directory. We use
  ;; here the same directory to permit the use of `rename-file` which is
  ;; atomic (useful for parallel makes)
  (let ((template (make-path (dirname output) "stk-tmp.")))
    (let-values (((tmp out) (create-temp-file template)))
      ;; Compile file in 'input' into file in 'tmp'
      (with-handler
       (lambda (c)
         ;; Compiler yields an (probably involuntary) error. Delete the
         ;; temporary file and re-raise error
         (when (file-exists? tmp) (delete-file tmp))
         (raise c))

       (do-compile out)
       (rename-file tmp output)))))



(export compile-file)
