;;; -*- Mode: Lisp; Package: COMMON-LISP-CONTROLLER -*-
;;;
;;; Copyright (C) 2000,2010  Peter Van Eynde and Kevin M. Rosenberg
;;; Licensed under the LLGPL, see debian/copyright file


(in-package #:cl-user)

#+ecl ;; Hush ECL
(setf *load-verbose* nil
      *load-print* nil)

(defpackage #:common-lisp-controller
  (:use #:common-lisp)
  (:export #:init-common-lisp-controller
	   #:init-common-lisp-controller-v4
	   #:compile-common-lisp-controller-v5
	   #:init-common-lisp-controller-v5
	   #:clc-require
	   #:*clc-quiet*)
  (:nicknames #:clc))

(in-package #:common-lisp-controller)

(defvar *clc-quiet* nil
  "If true then clc prints no messages")

;; Some general utilities to make the
;; descriptions shorter

(defvar *fasl-root* nil "Root of implementation's directories of binary files")
(defvar *source-root* #p"/usr/share/common-lisp/source/"
	"Root of source directories")
(defvar *systems-root* #p"/usr/share/common-lisp/systems/"
        "Root of systems directory")
(defvar *image-preferences* #p"/etc/common-lisp/images/"
	"Directory where user can choose what systems shall be added to
Images per default")
(defvar *implementation-name* nil "The name of the implementation,
used to name the directory in /var/cache/common-lisp-controller")

(define-modify-macro appendf (&rest lists) append)

(defun init-common-lisp-controller-v5 (implementation-name)
  ;; register the systems root:
  (setf *implementation-name* implementation-name)
  
  (pushnew :common-lisp-controller *features*)
  (pushnew :clc-os-debian *features*))

(defun compile-common-lisp-controller-v5 (implementation-name)
  "Compiles the clc files. Returns a list of fasls
that should be loaded in the list to enable clc"
  (setf *implementation-name* implementation-name)

  (pushnew :common-lisp-controller *features*)
  (pushnew :clc-os-debian *features*)

  (let* ((fasl-root (merge-pathnames
		     (make-pathname
		      :directory
		      `(:relative "0" ,*implementation-name*))
		     #p"/var/cache/common-lisp-controller/")))

    (labels ((source-filename (package-name filename)
	       (let ((file (parse-namestring filename)))
		 (merge-pathnames
		  (make-pathname
		   :name (pathname-name file)
		   :type (pathname-type file)
		   :directory (list :relative package-name))
		  *source-root*)))
	     #+ecl
	     (system-fasl-filename (package-name filename)
	       ;; this is complex because ecl
	       ;; should produce system fasls,
	       ;; and they have .o extension
	       (merge-pathnames 
		(make-pathname :type "o")
		(fasl-filename package-name filename)))
	     (fasl-filename (package-name filename)
	       ;; this is complex because ecl
	       ;; should produce system fasls,
	       ;; and they have .o extension
	       (let* ((file (parse-namestring filename))
		      (output-path
		       (merge-pathnames
			(make-pathname :name (pathname-name file)
				       :type (pathname-type file)
				       :directory (list :relative package-name))
			fasl-root))
		      (compiled-file-pathname
		       (compile-file-pathname
			output-path)))
		 compiled-file-pathname))

	     (compile-and-load (package-name filename)
	       (let* ((file-path (source-filename package-name filename))
		      (compiled-file-pathname
		       (progn
			 ;; first make the target directory:
			 (ensure-directories-exist
			  (fasl-filename package-name filename))
			 ;; now compile it:
			 (compile-file file-path
				       :output-file (fasl-filename package-name filename)
				       :print nil
				       :verbose nil))))
		 ;; then load it:
		 (load compiled-file-pathname)
		 ;; return fasl filename
		 compiled-file-pathname
		 ;; now for ecl: make the system file
		 #+ecl 
		 (compile-file file-path
			       :output-file
			       (system-fasl-filename package-name filename)
			       :print nil
			       :verbose nil
			       ;; make 'linkable object files' 
			       :system-p t))))

      ;; then asdf:
      ;; For SBCL, take advantage of it's REQUIRE/contrib directories integration
      #+sbcl
      (when (boundp 'sb-ext::*module-provider-functions*)
	(pushnew :sbcl-hooks-require cl:*features*))
      
      ;; return a list
      (prog1
	  (nconc
	   (list

	    ;; first ourselves:
	    (compile-and-load  "common-lisp-controller"
			       "common-lisp-controller.lisp")
	    ;; asdf
	    (compile-and-load  "cl-asdf" "asdf.lisp")
	    
	    (compile-and-load  "cl-asdf" "wild-modules.lisp")
	    
	    ;; now patch it::
	    (compile-and-load "common-lisp-controller"
			      "post-sysdef-install.lisp"))

	   ;; so that it will neither recalculate it nor save it in our image
	   (let ((*fasl-root* fasl-root))
	     ;; "load-user-image-components" is in the above-loaded files.
	     (funcall (symbol-function
		       (find-symbol
			(symbol-name :load-user-image-components)
			:common-lisp-controller)))))

	#+sbcl
	(setq cl:*features* (delete :sbcl-hooks-require  cl:*features*))))))

(defun init-common-lisp-controller-v4 (implementation-name)
  "configures common-lisp-controller. IMPLEMENTATION-NAME
is the name of this implementation. Fasl's will be created in
/var/cache/common-lisp-controller/<userid>/<implementation>"
  (compile-common-lisp-controller-v5 implementation-name)
  ;; no need to load them as they are already loaded
  (init-common-lisp-controller-v5 implementation-name))

(defun init-common-lisp-controller (fasl-root
                                    &key
                                    (source-root "/usr/share/common-lisp/")
                                    (version 2))
  (declare (ignore source-root version))
  ;; vodoo: extract the name of the implementation
  ;; from the old fasl directory...
  (init-common-lisp-controller-v4
   (first
    (last
     (pathname-directory
      (parse-namestring
       fasl-root))))))
