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

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

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

(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)))))))

(define default-cxx (foreign-value "C_TARGET_CXX" c-string))
(define default-cc (foreign-value "C_TARGET_CC" c-string))
(define default-cflags (foreign-value "C_TARGET_CFLAGS" c-string))
(define default-ldflags (foreign-value "C_TARGET_LDFLAGS" c-string))
(define default-libdir (foreign-value "C_TARGET_LIB_HOME" c-string))
(define default-libs (foreign-value "C_TARGET_MORE_LIBS" c-string))

(define remove-file-command
  (case (software-type)
    ((unix) "rm -f")
    ((windows) "del /f /q")
    (else "rm -f")))

(define (shellpath str)
  (qs (normalize-pathname str)))

(define (try-compile code #!key c++ (cc (if c++ default-cxx default-cc)) (cflags "") (ldflags "") 
                     (verbose #f) (compile-only #f))
  (let* ((fname (create-temporary-file "c"))
         (oname (pathname-replace-extension fname "o"))
         (r (begin
              (with-output-to-file fname (cut display code))
              (system 
               (let ((cmd (conc
                           cc " "
                           (if compile-only "-c" "") " "
                           cflags " " default-cflags " "
                           (shellpath fname) " -o " (shellpath oname) " "
                           (if compile-only
                               "" 
                               (conc "-L" default-libdir " " ldflags " " default-libs) )
                           (case (software-type) ((windows) " >nul: " " >/dev/null ") (else ""))
                           (if verbose "" "2>&1") ) ) )
                 (when verbose (print cmd " ..."))
                 cmd) ) ) ) )
    (when verbose (print (if (zero? r) "succeeded." "failed.")))
    (system (sprintf "~A ~A" remove-file-command (shellpath fname)))
    (system (sprintf "~A ~A" remove-file-command (shellpath oname)))
    (zero? r) ) )

)