;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Mon Aug 06 13:24:56 2007 +0530 <enometh@net.meer>
;;;   Time-stamp: <2008-08-23 15:57:24 madhu>
;;;   Bugs-To: enometh@net.meer
;;;   Status: Experimental. Do not redistribute.
;;;   Copyright (C) 2007 Madhu.  All Rights Reserved.
;;;
;;; Loader for compiling and loading cmucl-init.lisp
(in-package "CL-USER")

(defvar *binary-directory-fasl-root* "fasl:"
  "Root Directory of fasl files.") ;XXX

(defvar *binary-directory-pattern*
  (or #+scl
      (list "binary-scl")
      #+cmu
      (list "binary-cmucl")
      #+lispworks
      (list "binary-lispworks")
      #+allegro
      (list "binary-allegro")
      #+clisp
      (list "binary-clisp")
      #+sbcl
      (list "binary-sbcl")
      (cerror "Continue" "Unknown implementation."))
  "List of strings denoting directory components under fasl root.")

(defvar *binary-directory-version*
  (or #+scl
      (list
       (let* ((backend (c:backend-name c:*target-backend*))
	      (version (c:backend-fasl-file-version c:*target-backend*)))
	 (format nil "scl-~A-~D.~D.~D.~D" backend
		 (ldb (byte 8 24) version)
		 (ldb (byte 8 16) version)
		 (ldb (byte 8 8) version)
		 (ldb (byte 8 0) version))))
      #+(and nil cmu)
      (list
       (format nil "~(~x~)" (c:backend-fasl-file-version c:*target-backend*)))
      (list
       (lisp-implementation-version)))
    "List of strings denoting directory components under implementation's fasl
root.")

(defun binary-directory (pathname &rest dirnames)
  (when (or #+allegro (excl::logical-pathname-p (pathname pathname))
	    #+(or clisp lispworks) (system::logical-pathname-p (pathname pathname))
	    #+cmu (LISP::LOGICAL-PATHNAME-P (pathname pathname)))
    (setq pathname (translate-logical-pathname pathname)))
  (let* ((pathname-directory (pathname-directory pathname))
	 (last (if (endp (cdr pathname-directory))
		   nil
		   (last pathname-directory))))
    #+cmu
    (when (lisp::search-list-p (car last)) ;handle "host:/skt.lisp"
      (assert (lisp::search-list-defined (cadr pathname-directory)))
      (setq last nil))
    (let ((p (make-pathname :name nil :type nil :version nil
			    :directory
			    (append
			     (pathname-directory *binary-directory-fasl-root*)
			     last
			     *binary-directory-pattern*
			     dirnames
			     *binary-directory-version*))))
      p)))

(defvar *binary-directory-ensure-directories-exist* t)
(defvar *binary-directory-source-file-types* '("lisp" "l" "cl" "lsp"))

(defun lc (pathname &key library-p
	   force
	   (source-directory *default-pathname-defaults*)
	   (source-file-types *binary-directory-source-file-types*)
	   (create-directories *binary-directory-ensure-directories-exist*)
	   binary-directory
	   dry-run)
  "Compile and load pathnanme. CREATE-DIRECTORIES has no effect during
DRY-RUN."
  (prog* ((*default-pathname-defaults* source-directory)
	  (source-truename
	   (or (probe-file pathname)
	       (when (null (pathname-type pathname))
		 (some (lambda (source-file-type)
			 (probe-file
			  (make-pathname :type source-file-type
					 :defaults pathname)))
		       source-file-types))))
	  (binary-directory (or binary-directory
				(and source-truename
				     (binary-directory source-truename))
				(binary-directory pathname)))
	  (fasl
	   (let ((purported-fasl (compile-file-pathname
				  (or source-truename pathname))))
	     (make-pathname :name
			    (if library-p
				(concatenate 'string
					     (pathname-name purported-fasl)
					     "-library")
				(pathname-name purported-fasl))
			    :version (pathname-version purported-fasl)
			    :type (pathname-type purported-fasl)
			    :defaults binary-directory))))
     (if dry-run (return (values fasl source-truename)))
     retry
     (unless source-truename
       (error "Could not find source file: ~A" pathname))
     (if create-directories (ensure-directories-exist fasl))
     (when (or force
	       (< (or (handler-case (file-write-date fasl)
			(error (e)
			  (format t "Error: file-write-date: ~A: ~A." fasl e)
			  0))
		      0)
		  (file-write-date source-truename)))
       (print (list 'compile-file source-truename :output-file fasl))
       (multiple-value-bind (output-truename warnings-p failure-p)
	   (compile-file source-truename :output-file fasl)
	 (assert (equal (truename fasl) (truename output-truename)))
	 (when failure-p		;XXX
	   (format t "lc: compile-file returned: ~A."
		   (list output-truename warnings-p failure-p)))))
     (print (list 'load fasl))
     (restart-case (load fasl)
       (delete-fasl-and-retry ()
	 :report (lambda (stream)
		   (format stream "Delete ~A and retry compilation." fasl))
	 :test (lambda (condition)
		 (declare (ignore condition))
		 (probe-file fasl))
	 (delete-file fasl)
	 (go retry)))))

(setf (symbol-function 'lc-lite) #'lc)

(export '(binary-directory lc))