(in-package :ext)
;;; Written by Shinmera 2015
;;; adapted to clasp by Christian Schafmeister 2015

(defun llvm-short-version ()
  (ext:llvm-version))

;; don't include this if you already have a splitting function (you probably do)
#+(or)
(defun split (string split-char)
  (loop with out = (make-string-output-stream)
     with parts = ()
     for char across string
     do (if (char= char split-char)
            (let ((part (get-output-stream-string out)))
              (when (string/= "" part)
                (push part parts)))
            (write-char char out))
     finally (return (nreverse parts))))

(defun ensure-directory-namestring (namestring)
  (if (char= (char namestring (1- (length namestring)))
             #+windows #\\ #-windows #\/ )
      namestring
      (format NIL "~a/" namestring)))

(defun external-path-paths (&optional (var (ext:getenv "PATH")))
  (mapcar
   (lambda (namestring)
     (pathname (ensure-directory-namestring namestring)))
   (core:split var ":")))

(defvar *clang-names* (list
                       (core:fmt NIL "clang-{}" (llvm-short-version))
                       (core:fmt NIL "clang++-{}" (llvm-short-version))
                       "clang" "clang++"))

(defun discover-clang (&key debug (search-paths (external-path-paths)) (names *clang-names*))
  (or (ext:getenv "CLASP_CLANG_PATH")
      (and ext:*clasp-clang-path* (stringp ext:*clasp-clang-path*) (probe-file (pathname ext:*clasp-clang-path*)))
      (dolist (path search-paths)
        (dolist (n names)
          (let ((cp (make-pathname :name n :type nil :defaults path)))
            (when debug
              (format t "Searching for clang at ~a~%" cp))
            (let ((file (probe-file cp)))
              (when file (return-from discover-clang file))))))))

(defvar *clang-bin* (discover-clang))

 ;; This would only work after kernel/clos/conditions
#+(or)
(define-condition clang-not-found-error (error)
  ((tried-path :initarg :path :initform NIL :accessor tried-path))
  (:report (lambda (c s) (format s "Could not find clang~@[ on path ~s~]."
                                 (tried-path c)))))

(defun run-clang (args &key (clang *clang-bin*) output-file-name)
  "Run the discovered clang compiler on the arguments. This replaces a simpler version of run-clang."
  (unless clang
    (error "There is no clang compiler path defined!!!!"))
  (unless (probe-file clang)
    (error "Could not find clang at ~a" clang))
  ;; This would only work after kernel/clos/conditions
  #+(or)
  (labels ((read-path ()
             (list (pathname (read *query-io*))))
           (clang-usable-p ()
             (restart-case
                 (if (and clang (probe-file clang))
                     T
                     (error 'clang-not-found-error :path clang))
               (use-value (value)
                 :interactive read-path
                 :report "Use an alternative path for clang."
                 :test (lambda (c) (typep c 'clang-not-found-error))
                 (setf clang value)
                 NIL)
               (store-value (value)
                 :interactive read-path
                 :report "Store a new path for *CLANG-BIN*."
                 :test (lambda (c) (typep c 'clang-not-found-error))
                 (setf *clang-bin* value clang value)
                 NIL))))
    (loop until (clang-usable-p)))
  (when (member :debug-run-clang *features*)
    (let ((cmd (with-output-to-string (sout)
                 (core:fmt sout "{}" (namestring clang))
                 (dolist (arg args)
                   (core:fmt sout " {}" arg)))))
      (core:fmt t "run-clang:  {}%N" cmd)))
  (let ((start-time (get-internal-run-time)))
    (cmp::safe-system (list* (namestring clang) args) :output-file-name output-file-name)
    (setf llvm-sys:*accumulated-clang-link-time* (+ llvm-sys:*accumulated-clang-link-time* (* (/ 1.0 internal-time-units-per-second) (- (get-internal-run-time) start-time))))
    (incf llvm-sys:*number-of-clang-links*)))


(export 'run-clang)


#+darwin
(defun run-dsymutil (args &key (clang *clang-bin*) output-file-name)
  "Run the discovered clang compiler on the arguments. This replaces a simpler version of run-clang."
  (unless clang
    (error "There is no clang compiler path defined!!!!"))
  (let ((dsymutil (make-pathname :name "dsymutil" :type nil :defaults *clang-bin*)))
    (unless (probe-file dsymutil)
      (error "Could not find dsymutil at ~a" dsymutil))
    (when (member :debug-run-clang *features*)
      (let ((cmd (with-output-to-string (sout)
                   (core:fmt sout "{}" (namestring dsymutil))
                   (dolist (arg args)
                     (core:fmt sout " {}" arg)))))
        (core:fmt t "run-dsymutil:  {}%N" cmd)))
    (let ((start-time (get-internal-run-time)))
      (cmp::safe-system (list* (namestring dsymutil) args) :output-file-name output-file-name)
      (setf llvm-sys:*accumulated-clang-link-time* (+ llvm-sys:*accumulated-clang-link-time* (* (/ 1.0 internal-time-units-per-second) (- (get-internal-run-time) start-time))))
      (incf llvm-sys:*number-of-clang-links*))))

#+darwin
(export '(run-clang run-dsymutil))

(in-package #:cmp)

(defun as-shell-command (list-of-args)
  (with-output-to-string (sout)
    (princ (car list-of-args) sout)
    (dolist (c (cdr list-of-args))
      (core:fmt sout " {}" c))))

(defvar *safe-system-echo* nil)
(defvar *safe-system-max-retries* 4)
(defvar *safe-system-retry-wait-time* 0.1d0) ;; 100 milliseconds
;; The wait time will be doubled at each retry!

(defun safe-system (cmd-list &key output-file-name)
  (if *safe-system-echo*
      (core:fmt t "safe-system: {}%N" cmd-list))

  (multiple-value-bind (retval error-message)
      (ext:vfork-execvp cmd-list)

    (unless (eql retval 0)
      (error "Could not execute command with ext:vfork-execvp with ~s~%  return-value: ~d  error-message: ~s~%" cmd-list retval error-message)))

  (when output-file-name
    (let ((sleep-time *safe-system-retry-wait-time*))
      (dotimes (nm1 (- *safe-system-max-retries* 1))
        (let ((n (+ nm1 1)))
          (unless (probe-file output-file-name)
            (if (>= n *safe-system-max-retries*)
                (error "The file ~a was not created by shell command: ~a" output-file-name (as-shell-command cmd-list))
                (progn
                  (if *safe-system-echo*
                      (core:fmt t "safe-system: Retry count = {} of {}%N" n *safe-system-max-retries*))
                  (core::sleep sleep-time)
                  (setq sleep-time (* 2 sleep-time)))))))))

  ;; Return T if all went well
  t)
