;;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
;;;; *************************************************************************
;;;; FILE IDENTIFICATION
;;;;
;;;; Name:     start.lisp
;;;; Purpose:  Initial boot file for all lisp systems
;;;; Author:   Kevin M. Rosenberg
;;;; Created:  Feb 2002
;;;;
;;;; This is the file I load from all of my Lisp startup files. I have it
;;;; stored in ~/src/lisp/lboot/start.lisp. I use code such as the following
;;;; to load it from the Lisp startup file:
;;;;
;;;;  (let ((boot-file (merge-pathnames
;;;;                     (make-pathname :name "start" :type "lisp" 
;;;;                            :directory '(:relative "src" "lisp" "lboot"))
;;;;                     *load-pathname*)))
;;;;    (when (probe-file boot-file)
;;;;       (load boot-file)))
;;;;
;;;; The startup files used by Lisp implementations are:
;;;;    Allegro    .clinit.cl
;;;;    CMUCL      .cmucl-init.lisp
;;;;    Lispworks  .lispworks
;;;;    OpenMCL    openmcl-init.lisp
;;;;    SBCL       .sbclrc 
;;;;
;;;; This file tries to be minimal as it will not be compiled.
;;;; Setups up the LBOOT package and functions to automatically compile
;;;; files as need upon load. Then, this file loads the files that actually
;;;; setup the environment.
;;;;
;;;; This file is free software and in the public domain. It can be used
;;;; by anybody for any purpose.
;;;;   
;;;; ADDITONAL FILES:
;;;;   I keep local copies of asdf.lisp and defsystem.lisp in
;;;;   ~/src/lisp/lboot/lib/ in case they are not already loaded into
;;;;   the running lisp environment.
;;;; 
;;;; $Id: start.lisp 9319 2004-05-12 18:42:16Z kevin $
;;;; *************************************************************************

(in-package #:cl-user)

(defpackage #:lboot
  (:use #:common-lisp)
  (:export 
   #:pathname-host-device-directory
   #:compile-file-as-needed
   #:pathname-relative-my-lisp
   #:*my-lisp-path*
   #:*lisp-lib-path*
   #:*compiler-name*
   #:newer-file-p
   #:load-compiled-file
   #:load-compiled-relative-my-lisp
   #:append-binary-directory
   #:pathname-drive-letter
   #:cwd
   #:find-directory
   #:directory-up
   #:quit
   #:pathname-relative-lisp-lib
   #:pathname-relative-clocc
   #:pathname-drive-letter
   #:probe-directory
   #:load-file-if-exists
   ))

(in-package #:lboot)

(defun pathname-host-device-directory (path)
  (check-type path pathname)
  (make-pathname :host (pathname-host path)
		 :device (pathname-device path)
		 :directory (pathname-directory path)))

(defparameter *my-lisp-path*
  (merge-pathnames
   (make-pathname :directory '(:relative :back))
   (lboot:pathname-host-device-directory *load-truename*)))


(defparameter *compiler-name*
    #+(and allegro-v6.2 ics acl-case-sensitive) "mlisp"
    #+(and allegro-v6.2 (not ics) acl-case-sensitive) "mlisp8"
    #+(and allegro-v6.2 ics (not acl-case-sensitive)) "alisp"
    #+(and allegro-v6.2 (not ics) (not acl-case-sensitive)) "alisp8"
    #+(and allegro-v7.0 ics acl-case-sensitive) "mlisp-v7"
    #+(and allegro-v7.0 (not ics) acl-case-sensitive) "mlisp8-v7"
    #+(and allegro-v7.0 ics (not acl-case-sensitive)) "alisp-v7"
    #+(and allegro-v7.0 (not ics) (not acl-case-sensitive)) "alisp8-v7"
    #+lispworks4.2 "lispworks4.2"
    #+lispworks4.3 "lispworks4.3"
    #+clisp "clisp"
    #+cmu "cmucl"
    #+scl "scl"
    #+(and sbcl sb-thread) "sbclmt"
    #+(and sbcl (not sb-thread)) "sbcl"
    #+corman "corman"
    #+(and mcl (not openmcl)) "mcl"
    #+openmcl "openmcl"
    #-(or allegro lispworks clisp cmu sbcl scl corman mcl openmcl) "unknown")


(defparameter *binary-directory-list* `(".bin" ,*compiler-name*))

(defun append-binary-directory (base-directory)
  "Append binary directory onto a directory list"
  (append base-directory *binary-directory-list*))

(defun >-num (x y)
  "Return T if x and y are numbers and x > y"
  (and (numberp x) (numberp y) (> x y)))

(defun newer-file-p (file1 file2)
  "Is file1 newer (written later than) file2?"
  (>-num (if (probe-file file1) (file-write-date file1))
	 (if (probe-file file2) (file-write-date file2))))

(defun compile-file-as-needed (src-path &optional dest-path)
  "Compiles a file if needed, returns path. For CLISP, needs to be
passed a non-logical pathname"
  (unless dest-path
    (setq dest-path (compile-file-pathname src-path))
    (setq dest-path
	  (make-pathname :defaults dest-path
			 :directory (append-binary-directory
				     (pathname-directory dest-path)))))
  (when (or (not (probe-file dest-path))
	    (lboot:newer-file-p src-path dest-path))
    (ensure-directories-exist dest-path)
    (compile-file src-path :output-file dest-path))
  dest-path)

(defun load-compiled-file (path &optional (compile-if-needed t))

  "Load a file, optionally compiled"
  (cond
    ((probe-file path)
     (if compile-if-needed
	 (load (lboot:compile-file-as-needed path))
	 (load path))
     t)
    (t
     (warn "Unable to find file ~A" path)
     nil)))

(defun pathname-relative (base dirs &optional name type)
  (merge-pathnames 
   (make-pathname :directory (if dirs
				 (cons :relative dirs)
				 (list :relative))
		  :name name
		  :type (if type
			    type
			    (pathname-type *load-truename*)))
   base))

(defun pathname-relative-my-lisp (dirs &optional name type)
  (pathname-relative *my-lisp-path* dirs name type))

(defun load-compiled-relative-my-lisp (dirs name &optional type)
  (load-compiled-file (pathname-relative-my-lisp dirs name type)))

;;; Load local copies of System definition packages if they have not
;;; already been loaded.

#-asdf (load-compiled-relative-my-lisp '("lboot" "lib") "asdf")
#-mk-defsystem (load-compiled-relative-my-lisp '("lboot" "lib") "defsystem")

;;; Further LBOOT files
(load-compiled-relative-my-lisp '("lboot") "utils")
(load-compiled-relative-my-lisp '("lboot") "systems")
#-common-lisp-controller (load-compiled-relative-my-lisp '("lboot") "non-clc")