;; Quick hack to be put into ~/.sbclrc to make SBCL look around for its source
;; where the very binary it is running is put. As a _fallback_ we look at
;; $SBCL_HOME.

;; Note: CMUCL once did this by default.

;; We take the pathname of the very binary we are and keep merging
;; "src/code/fd-stream.lisp" to it while we strip directory components from
;; the end. Hence if e.g. you have a fresh build and the binary is
;; ~/foo/src/runtime/sbcl we find ~/foo/src/code/fd-stream.lisp and call
;; ~/foo/ the SB-EXT:SET-SBCL-SOURCE-LOCATION (which btw is a misnomer as it
;; points to the SBCL directory, not the sources within it).

(labels ((get-executable-pathname ()
           (labels
               ((my-native-pathname (string)
                  (let ((pn (sb-ext:parse-native-namestring
                             string nil
                             (make-pathname :host sb-impl::*physical-host*
                                            :device :unspecific :directory nil :name nil :type nil :version nil)
                             :as-directory nil)))
                    (make-pathname :directory (remove "" (pathname-directory pn) :test #'equal)
                                   :defaults pn))))
             ;;
             #+DARWIN
             (let* ((buf-size 1024)
                    (buf (sb-alien:make-alien (sb-alien:unsigned 8) buf-size)))
               (unwind-protect
                    (let ((lenf (sb-alien:make-alien (sb-alien:unsigned 32))))
                      (unwind-protect
                           (progn
                             (setf (sb-alien:deref lenf) buf-size)
                             (let ((ret (sb-alien:alien-funcall
                                         (sb-alien:extern-alien "_NSGetExecutablePath"
                                                                (function (sb-alien:signed 32)
                                                                          (* (sb-alien:unsigned 8))
                                                                          (* (sb-alien:unsigned 32))))
                                         buf lenf)))
                               (when (zerop ret)
                                 (setf (sb-alien:deref buf (sb-alien:deref lenf)) 0)
                                 (my-native-pathname
                                  (sb-alien::c-string-to-string (sb-alien:alien-sap buf) :utf-8 'character)))))
                        (sb-alien:free-alien lenf)))
                 (sb-alien:free-alien buf)))
             #+WIN32
             (multiple-value-bind (buf len)
                 (let* ((size 128)
                        (buf (sb-alien:make-alien (sb-alien:unsigned 16) size)))
                   (loop
                     (let ((res (sb-alien:alien-funcall
                                 (sb-alien:extern-alien "GetModuleFileNameW"
                                                        (function (sb-alien:unsigned 32)
                                                                  sb-sys:system-area-pointer sb-sys:system-area-pointer
                                                                  (sb-alien:unsigned 64)))
                                 (sb-sys:int-sap 0) (sb-alien:alien-sap buf) size)))
                       (unless (= size res)
                         (return (values buf res)))
                       (sb-alien:free-alien buf)
                       (setq size (* size 2))
                       (setq buf (sb-alien:make-alien (sb-alien:unsigned 16) size)))))
               (prog1
                   (and (not (zerop len))
                        (my-native-pathname
                         (sb-alien::c-string-to-string (sb-alien:alien-sap buf) #+LITTLE-ENDIAN :utf-16le
                                                       #-LITTLE-ENDIAN :utf-16be
                                                       'character)))
                 (sb-alien:free-alien buf)))
             #+LINUX
             ;; Linux is dead easy.
             (ignore-errors (truename "/proc/self/exe"))
             #-(OR DARWIN WIN32 LINUX)
             nil))
         ;;
         (guess-source-location ()
           (labels ((guess-1 (pn)
                      (when pn
                        (setq pn (make-pathname :name nil :type nil :defaults pn))
                        (let ((dir (pathname-directory pn)))
                          (loop
                            (let ((candidate (make-pathname :directory dir :defaults pn)))
                              (let ((probe (merge-pathnames (make-pathname :name "fd-stream" :type "lisp"
                                                                           :directory '(:relative "src" "code")
                                                                           :defaults candidate)
                                                            candidate)))
                                (when (probe-file probe)
                                  (return candidate))))
                            (setq dir (butlast dir))
                            (when (< (length dir) 1)
                              (return nil)))))))
             (or (guess-1 (get-executable-pathname))
                 (guess-1 (sb-ext:posix-getenv "SBCL_HOME"))))) )
  ;;
  (let ((source-location
         (guess-source-location)))
    (when source-location
      (format t "~&;; We believe our sources are at ~S~%" source-location)
      (sb-ext:set-sbcl-source-location source-location))))