;;; -*- 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-30 16:34:10 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:"
  "This needs to be set before loading the LC-LITE file.  This should be a
pathname to a durectory.")

(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")
      (cerror "Continue" "Unknown implementation."))
  "List of strings."  )

(defvar *binary-directory-version*
  (or
   ;; #+cmu
   ;; (list (format nil "~(~x~)"
   ;; (c:backend-fasl-file-version c:*target-backend*)))
   (list (lisp-implementation-version))))

(defun binary-directory (pathname &rest dirnames)
  #+allegro
  (if (excl::logical-pathname-p (pathname pathname))
      (setq pathname (translate-logical-pathname pathname)))
  #+(or clisp lispworks)
  (if (system::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)))

(defun lc-lite (pathname &key library-p
		force
		(source-directory *default-pathname-defaults*)
		(source-file-types '("lisp" "l" "cl" "lsp"))
		(create-directories t)
		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-from lc-lite (values fasl source-truename)))
     retry
     (unless source-truename
       (error "Could not find source file: ~S" pathname))
     (if create-directories (ensure-directories-exist fasl))
     (when (or force
	       (< (or (ignore-errors (file-write-date fasl)) 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
	   (warn "compile-file returned: ~S"
		 (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 ~S and retry compilation." fasl))
	 :test (lambda (condition)
		 (declare (ignore condition))
		 (probe-file fasl))
	 (delete-file fasl)
	 (go retry)))))