source: project/release/5/compile-file/tags/1.0/compile-file.scm @ 35590

;;;; compile-file.scm - Programmatic compiler invocation

(declare
  (unit compile-file)
  (fixnum-arithmetic))

(module compile-file
  (compile-file compile-file-options)

(import (chicken base)
        (chicken condition)
        (chicken platform)
        (chicken file)
        (chicken foreign)
        (chicken format)
        (chicken pathname)
        (chicken process)
        (chicken string)
        ;; rename "load" to avoid conflict with keyword argument
        (rename (scheme) (load load-file)))

(define compile-file-options
  (make-parameter '("-O2" "-d2")))

(define compile-file
  (let ((csc (foreign-value "C_CSC_PROGRAM" c-string))
        (path (foreign-value "C_INSTALL_BIN_HOME" c-string)))
    (lambda (filename #!key options output-file (load #t) verbose)
      (let* ((cscpath (or (file-exists? (make-pathname path csc)) "csc"))
             (tmpfile (and (not output-file) (create-temporary-file "so")))
             (crapshell (eq? (build-platform) 'mingw32))
             (cmd (sprintf "~a~a -s ~a ~a -o ~a~a"
                    (if crapshell "\"" "")
                    (qs cscpath)
                    (string-intersperse
                     (or options
                         (compile-file-options)))
                    (qs filename)
                    (qs (or output-file tmpfile))
                    (if crapshell "\"" ""))))
        (when verbose (print "  " cmd))
        (let ((status (system cmd)))
          (cond ((zero? status)
                 (unless output-file
                   (on-exit
                    (lambda ()
                      (handle-exceptions ex #f (delete-file* tmpfile)))))
                 (when load
                   (let ((f (or output-file tmpfile)))
                     (handle-exceptions ex
                         (begin
                           (delete-file* f)
                           (abort ex))
                       (load-file f)
                       f))))
                (else #f))))))))