;;;; chicken-scheme.scm


(module chicken-scheme ()

(import scheme
        (chicken base)
        (chicken foreign)
        (chicken process)
        (chicken process-context)
        (chicken file)
        (chicken file posix)
        (chicken format)
        (chicken irregex)
        (chicken io)
        (chicken platform)
        (chicken pathname)
        matchable)


(define-foreign-variable +csc-program+ c-string "C_CSC_PROGRAM")
(define-foreign-variable +csi-program+ c-string "C_CSI_PROGRAM")
(define-foreign-variable +binpath+ c-string "C_INSTALL_BIN_HOME")

(define *debug*
  (get-environment-variable "CHICKEN_SCHEME_DEBUG") )

(define *chicken-scheme-hook* 
  (and (not *debug*)
       (get-environment-variable "CHICKEN_SCHEME_HOOK") ))

(define *cache* 
  (make-pathname 
   (or (get-environment-variable "HOME") "/")
   ".chicken-scheme.cache") )

(define *options* 
  (or (get-environment-variable "CHICKEN_SCHEME_OPTIONS")
      (if *debug* "-v -v" "-O2")) )

(define *csc* (make-pathname +binpath+ +csc-program+))
(define *csi* (make-pathname +binpath+ +csi-program+))

(define *exe* 
  (and (eq? 'windows (software-type))
       (not (eq? 'cygwin (build-platform)))
      "exe"))

(define +md5sum-regex+
  (irregex '(: bos (? #\\) (* space) (submatch (+ xdigit)) (* space))))

(define *md5sum-program*
  (cond-expand
    (netbsd "md5 -n")
    ((or freebsd openbsd dragonfly) "md5 -r")
    (else "md5sum")))

(define (usage code)
  (print "usage: chicken-scheme [-help] [-purge] [-list] [-cache] [FILENAME ARGUMENT ...]")
  (exit code) )

(define (purge)
  (when *debug*
    (print "purging " *cache* " ..."))
  (when (directory-exists? *cache*)
    (for-each 
     (lambda (f) (delete-file* (make-pathname *cache* f))) 
     (directory *cache*))) )

(define (md5sum filename)
  (let ((qsource (qs (normalize-pathname filename))))
    (case (software-version)
      ((macosx) 
       (with-input-from-pipe (sprintf "md5 -q ~a" qsource) read-line) )
      (else
       (with-input-from-pipe 
	(sprintf "~a ~a" *md5sum-program* qsource)
	(lambda () 
	  (let ((input (read-line)))
	    (cond ((irregex-search +md5sum-regex+ input) =>
                   (lambda (m) (irregex-match-substring m 1)))
		  (else (error "cannot compute md5sum" input))))))))))

(define scan-head
  (let ((rx (irregex " *;[ ;]*AUTOCOMPILE *: *(.*)")))
    (lambda (fname proc)
      (with-input-from-file fname
	(lambda ()
	  (read-line)			; she-bang line
	  (let loop ()
	    (let ((ln (read-line)))
	      (cond ((eof-object? ln))
		    ((irregex-match rx ln) =>
		     (lambda (m)
		       (proc (irregex-match-substring m 1))
		       (loop)))))))))))

(define (run fail fstr . args)
  (let ((cmd (apply sprintf fstr args)))
    (when *debug* (print "  " cmd))
    (let ((r (system cmd)))
      (cond ((zero? r))
	    (else
	     (when fail (fail))
	     (fprintf 
	      (current-error-port) 
	      "command failed with non-zero exit status ~a:~%~%  ~a~%" r cmd)
	     (exit 1))))) )

(define (compile-and-run prg args)
  (unless (directory-exists? *cache*)
    (when *debug* 
      (print "creating " *cache*) )
    (create-directory *cache*) )
  (let* ((hash (md5sum prg))
	 (cached (normalize-pathname (make-pathname *cache* hash *exe*))))
    (when (or (not (file-exists? cached))
	      (> (file-modification-time prg)
		 (file-modification-time cached) ) )
      (let* ((qcached (qs cached))
	     (qprg (qs prg))
	     (errfile (normalize-pathname (create-temporary-file "tmp")))
	     (qerrfile (qs errfile)))
	(scan-head 
	 prg 
	 (lambda (opts)
	   (set! *options* (string-append *options* " " opts))))
	(when *chicken-scheme-hook*
	  (run #f "~a start ~a ~a" *chicken-scheme-hook* qprg qerrfile) )
	(run (lambda ()
	       (if *chicken-scheme-hook*
		   (run #f "~a fail ~a ~a" *chicken-scheme-hook* qprg qerrfile)
		   (display (with-input-from-file errfile (cut read-string #f))) ) )
	     "~a ~a ~a -o ~a ~a"
	     *csc* *options* qprg qcached
	     (if *debug* "" (string-append "> " qerrfile)))
	(when *chicken-scheme-hook*
	  (run #f "~a end ~a ~a" *chicken-scheme-hook* qprg qerrfile) )
	(delete-file errfile) ) )
    (process-execute cached args) ) )

(define (main args)
  (match args
    (()
     (process-execute *csi*) )
    (((or "-h" "-help" "--help") . _)
     (usage 0) )
    (("-purge")
     (purge) )
    (("-cache")
     (print *cache*))
    (("-list")
     (for-each print (directory *cache*)))
    ((filename args ...)
     (compile-and-run filename args) )
    (_ (usage 1))))

(main (command-line-arguments))

)