;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: USER; Base: 10; -*-
;;;_____________________________________________________________________________
;;;
;;;                       System: DEFINE-SYSTEM
;;;                       Module: 
;;;
;;; Copyright (c): Forschungsgruppe DRUID, Hubertus Hohl
;;;                Universitaet Stuttgart
;;;
;;; File: /usr/local/lisp/xit/define-system.lisp
;;; File Creation Date: 04/16/91 09:10:30
;;; Last Modification Time: 08/04/92 10:38:25
;;; Last Modification By: Matthias Ressel
;;;
;;;
;;; Changes (worth to be mentioned):
;;; ================================
;;;
;;; 05/21/1991 (Hubertus) added support for defining subsystems
;;; 09/16/1991 (Matthias) added tag-system
;;;                       keyword simulate.
;;; 02/03/1992 (Matthias) Incompatible change in option specification of
;;;                       modules: Is now a disembodied property list
;;;                       (no problem if you never had more than one option)
;;;                       Only directories are evaluated.
;;; 05/27/1992 (Hubertus) load-system now tries to load source file if no
;;;                       binary is present.
;;; 06/10/1992 (Hubertus) put define-system utility in separate package PMDS
;;; 08/04/1992 (Matthias) load-system is a now a NOP if already loaded (or
;;;                       compiled). New reload-system forces loading.
;;;
;;;_____________________________________________________________________________


(in-package :user)

#+(or Genera Minima)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew :xit-ansi-common-lisp *features*))

#+xit-ansi-common-lisp
(defpackage pmds
  (:use common-lisp)
  (:export "DEFINE-SYSTEM"
	   "UNDEFINE-SYSTEM"
	   "DESCRIBE-SYSTEM"
	   "TAG-SYSTEMS"
	   "TAG-SYSTEM"
	   "COMPILE-SYSTEM"
	   "RECOMPILE-SYSTEM"
	   "COMPILE-ONLY-SYSTEM"
	   "RECOMPILE-ONLY-SYSTEM"
	   "LOAD-SYSTEM"
	   "RELOAD-SYSTEM"
	   )
  )

#-xit-ansi-common-lisp
(in-package "PMDS" :use '("LISP"))
#-xit-ansi-common-lisp
(export '(DEFINE-SYSTEM UNDEFINE-SYSTEM DESCRIBE-SYSTEM TAG-SYSTEMS TAG-SYSTEM
          COMPILE-SYSTEM RECOMPILE-SYSTEM COMPILE-ONLY-SYSTEM
          RECOMPILE-ONLY-SYSTEM LOAD-SYSTEM RELOAD-SYSTEM
)        )

(pushnew :POOR-MANS-DEFINE-SYSTEM *features*)

(in-package :pmds)


;;;____________________________________
;;;
;;;  A poor man's defsystem facility
;;;____________________________________

#|| Example of usage:

Defining a system:

(define-system <name>
    (:default-directory <dir>)
  
  (:module before-patches
	   ("patch-1" "patch-2")
	   (:default-directory <patch-dir>))
  (:module after-patches
	   ("patch-4711")
	   (:default-directory <patch-dir>))
  (:module macros
	   ("defs-1" "defs-2"))
  (:module main
	   ("first-file" "second-file" "third-file")
	     ))
  (:module foo-subsystem
	   :subsystem
	   ;; 02/03/1992 (Matthias) ATTENTION: Incompatible syntax change:
	   (:default-directory <subsystem-directory>
	    :system-definition <system-def>))
  (:serial before-patches macros main after-patches)
  (:serial before-patches foo-subsystem))

NOTE: Directory specification (e.g. <dir>, <patch-dir>) are evaluated, 
everything else is implicitely quoted. 


User Interface Functions:
=========================

define-system <name> (&rest options &key default-directory)
                 &rest modules&dependencies)
undefine-system <name> &rest ignored

describe-system <name> &optional (<stream> *standard-output*)
tag-systems (<nama1> <name2> ...) &rest options &key tags-directory)
tag-system <name> &rest options &key (tags-directory default-directory)
 
compile-system <name> &rest <parameters> &key
recompile-system <name> &rest <parameters> &key
compile-only-system <name> &rest <parameters> &key
recompile-only-system <name> &rest <parameters> &key
load-system <name>  &rest  &key <parameters> &key
reload-system <name>  &rest  &key <parameters> &key


valid <parameters>:
:include-subsystems t
:system-definition  nil 
:simulate nil

||#


(defvar *current-lisp-file-types*
        (let ((extensions
	       (car
		'(#+(and genera (not imach)) ("LISP" . "BIN")
		  #+(and genera imach)       ("LISP" . "IBIN")
		  #+(and Lucid SPARC)        ("lisp" . "sbin")
		  #+(and Lucid mc68000)      ("lisp" . "lbin")
		  #+excl                     ("lisp" . "fasl")
		  #+TI     ("lisp" . #.(string (si::local-binary-file-type)))
		  #+CLISP                    ("lsp" . "fas")
		  ))))
	  (or extensions
	      '("lisp" . "fasl"))))

(defun make-source-pathname (filename defaults)
  (make-pathname #+symbolics :raw-name
		 #-symbolics :name
		 filename
		 :type (car *current-lisp-file-types*)
		 :defaults defaults))

(defun make-binary-pathname (filename defaults)
  (make-pathname #+symbolics :raw-name
		 #-symbolics :name
		 filename
		 :type (cdr *current-lisp-file-types*)
		 :defaults defaults))

(defun make-untyped-pathname (filename defaults)
  (make-pathname #+symbolics :raw-name
		 #-symbolics :name
		 filename
		 :type nil
		 :defaults defaults))

(defun compile-file_if-needed (input-pathname &key output-file force-compile
						   simulate)
  (let ((binary (or output-file
		    (make-binary-pathname
		     (pathname-name input-pathname)
		     input-pathname))))
    (when (or force-compile
	      (null (probe-file binary))
	      (> (file-write-date input-pathname)
		 (file-write-date binary)))
      (if simulate
	  (format t "~&Compile ~A.~%" (namestring input-pathname))
	(compile-file input-pathname :output-file output-file)))))

(defun load-file_if-needed (pathname &key force-load simulate)
  (let ((path (make-untyped-pathname (pathname-name pathname)
				     pathname)))
    (when force-load
      (if simulate
	  (format t "~&Load ~a.~%" (namestring path))
	(load path)))))

(defun operate-on-sources (operation sources directory &key simulate)
  (declare (special *system-sources-pathnames*))
  (check-type operation (member :load :reload :compile :compile-only :recompile-only
				:recompile
				:get-sources))
  (dolist (filename sources) 
    (let ((binary (make-binary-pathname filename directory)))
      (case  operation
	(:compile-only 
	 (compile-file_if-needed
	  (make-source-pathname filename directory)
	  :output-file
	  binary
	  :simulate simulate))
	(:recompile-only
	 (compile-file_if-needed
	  (make-source-pathname filename directory)
	  :output-file
	  binary
	  :force-compile t
	  :simulate simulate))
	((:compile :recompile)
	 (compile-file_if-needed
	  (make-source-pathname filename directory)
	  :output-file
	  binary
	  :force-compile (eq operation :recompile)
	  :simulate simulate)
	 (load-file_if-needed binary :force-load t :simulate simulate))
	((:load :reload)
	 (load-file_if-needed binary :force-load t :simulate simulate))
	(:get-sources
	   (pushnew (namestring (make-source-pathname filename directory))
		    *system-sources-pathnames*))
	))))


(defstruct system-definition
  name
  default-directory
  options
  ordered-modules
  (loaded nil))

(defstruct module
  name
  default-directory
  sources
  options)

(defun module-is-subsystem-p (module)
  (eq (module-sources module) :subsystem))

(defvar *system-definitions* ())

(defun get-system-definition (name &optional system-definition-file (error-p t))
  (cond (system-definition-file
	 (load system-definition-file)
	 (get-system-definition name))
	(t  
	 (or (find name *system-definitions* :key #'system-definition-name)
	     (if error-p
		 (error "Could not find a system named ~S" name)
	         nil)))))

(defun add-system-definition (name default-directory options ordered-modules)
  (let ((sysdef (get-system-definition name nil nil)))
    (cond (sysdef
	(setf (system-definition-ordered-modules sysdef) ordered-modules)
	(setf (system-definition-default-directory sysdef) default-directory)
	(setf (system-definition-options sysdef) options))
	(t
      (push (make-system-definition
	     :name name
	     :default-directory default-directory
	     :options options
	     :ordered-modules ordered-modules)
	    *system-definitions*)))
    name))

(defun operate-on-system (operation name &rest options
			  &key (include-subsystems t)
			       (system-definition nil)
			       (simulate nil)
			       &allow-other-keys)
  (let ((sysdef (get-system-definition name system-definition))
	(skip-operation-on-modules nil))
    (format t "~&; ~A system ~A ... " operation name)
    (case operation
      (:load (when (system-definition-loaded sysdef)
	       (setq skip-operation-on-modules t)
	       (format t "already loaded."
		       name)))
      (otherwise
       (format t "~%")))
    (unless skip-operation-on-modules
      (dolist (module (system-definition-ordered-modules sysdef)) ; serial
	(apply #'operate-on-module operation module options))
      (case operation
	(:get-sources)
	((:load :reload :compile :recompile)
	 (setf (system-definition-loaded sysdef) t)
	 (format t "~&; done.~%"))
	(otherwise
	 (format t "~&; done.~%"))))))

(defun operate-on-module (operation module &rest system-options
					   &key (simulate nil)
						(include-subsystems t)
						&allow-other-keys)
  (cond ((not (module-is-subsystem-p module))
	 (format t "~&; ~A module ~A ... ~%" operation (module-name module))
	   (operate-on-sources operation (module-sources module) 
			       (module-default-directory module)
			       :simulate simulate))
	(include-subsystems
	 (format t "~&; ~A subsystem ~A ... ~%" operation (module-name module))
	 (apply #'operate-on-system operation (module-name module)
		:system-definition
		(make-source-pathname
		 (or (getf (module-options module) :system-definition)
		     "defsystem")
		 (module-default-directory module))
		system-options))))


;;;__________________________
;;;
;;; User Interface Functions
;;;__________________________

(defun load-system (name &rest options)
  (apply #'operate-on-system :load name options))

(defun reload-system (name &rest options)
  (apply #'operate-on-system :reload name options))

(defun compile-system (name &rest options)
  (apply #'operate-on-system :compile name options))

(defun compile-only-system (name &rest options)
  (apply #'operate-on-system :compile-only name options))

(defun recompile-system (name &rest options)
  (apply #'operate-on-system :recompile name options))

(defun recompile-only-system (name &rest options)
  (apply #'operate-on-system :recompile-only name options))

(defun describe-system (name &optional (stream *standard-output*))
  (let ((sysdef (get-system-definition name)))
    (format stream "~%System ~A is defined with the following properties:~
                    ~%  default-directory: ~a~
                    ~%  options: ~S~
                    ~%  loaded: ~S" name
		    (system-definition-default-directory sysdef)
		    (system-definition-options sysdef)
		    (system-definition-loaded sysdef))
    (format stream "~%System ~A has ~D modules which are operated on in the following order:~%"
	    name
	    (length (system-definition-ordered-modules sysdef)))
    (dolist (module (system-definition-ordered-modules sysdef))
      (if (module-is-subsystem-p module)
	  (format stream "  Subsystem ~A~%"
		  (module-name module))
	(format stream " Module ~A has files:~{ ~A~}~%"
		(module-name module)
		(module-sources module)))
      (format stream "~@[   default-directory: ~a.~%~]~
                     ~@[   options: ~S.~%~] "
	      (if (getf (module-options module) :default-directory)
		  (module-default-directory module))
	      (module-options module)))
    (values)))

(defun tag-system (name &rest options &key tags-directory &allow-other-keys)
  (apply #'tag-systems (list name) :tags-directory
	 (let ((sysdef (get-system-definition name)))
	   (or tags-directory
	       (getf (system-definition-options sysdef) :tags-directory)
	       (system-definition-default-directory sysdef)))
	 options))

(defun tag-systems (names &rest options &key tags-directory &allow-other-keys)
  #-(or excl lucid)
  (format t "; Sorry. Can't run shell command to call etags.~%")
  #+(or excl lucid)
  (let ((system-sources-names (apply #'get-sources names options)))
    (cond (system-sources-names
	   (when tags-directory
	     (format t "; cd ~a~%" (namestring tags-directory)))
	   (format t "; etags system~P~{ ~a~} ...~%" (length names) names)
	   (finish-output)
	   (etags-sources tags-directory system-sources-names)
	   (format t "; done."))
	  (t (format t "; No sources. Bye.~%")))))

(defparameter *shell-command-maximal-length* 1900)

(defun etags-sources (tags-directory system-sources-names)
  (let ((command (if tags-directory
		     (format nil "(cd ~a; etags ~{ ~a~})"
			     tags-directory system-sources-names)
		   (format nil "etags  ~{ ~a~}" system-sources-names))))
    (when (> (length command) *shell-command-maximal-length*)
      (warn "etags: absolute pathnames too long, trying relative ones...")
      (when tags-directory
	(setq system-sources-names
	    (mapcar #'(lambda (source)
			(relative-source-name source tags-directory))
		    system-sources-names))
	(setq command (format nil "(cd ~a; etags ~{ ~a~})"
			      tags-directory system-sources-names)))
      (cond ((> (length command) *shell-command-maximal-length*)
	     (warn "etags failed: too many and too long pathnames.")
	     (return-from etags-sources))))
    (#+excl run-shell-command
     #+lucid lcl:shell
     #+CLISP shell
	    command)))

(defun relative-source-name (source tags-directory)
  (let* ((source (namestring (truename source)))
	(tags-directory (namestring (truename tags-directory)))
	(prefix-length (length tags-directory)))
    (setq tags-directory (cond ((char-equal (char tags-directory (1- prefix-length))
					#\/)
				tags-directory)
			       (t (incf prefix-length)
				  (concatenate 'string tags-directory "/"))))
    (if (string-equal (subseq source 0 prefix-length) tags-directory)
	(subseq source prefix-length)
      source)))
    
	   

(defun get-sources (names &rest options)
   (let* ((*system-sources-pathnames* ()))
	(declare (special *system-sources-pathnames*))
	(dolist (name names)
	  (apply #'operate-on-system :get-sources name options))
	*system-sources-pathnames*))
     

;;; Todo: Get rid of the eval's 

(defun eval-options (&rest options)
  options)
  
(defmacro define-system (name (&rest options &key default-directory)
			 &rest modules&dependencies)
  (let ((module-defs ()) (dependencies ()))
    (dolist (item modules&dependencies)
      (ecase (car item)
	(:module
	  (pushnew `(make-module :name ',(second item) ; module name
		    :sources ',(third item) ; filenames or :subsystem
		    :default-directory ,(or
					 (getf (fourth item) :default-directory)
					 default-directory)
		    :options ',(fourth item))
		   module-defs))
	(:serial (push (cdr item) dependencies))))
    `(let ((modules nil))
       ,@(mapcar #'(lambda (def)
		     `(pushnew ,def modules :key #'module-name))
		 module-defs)
       (add-system-definition
	',name ,default-directory
	',options
	;; CCC The followin sorting of dependencies is wrong
	;; CCC Doesn't work, e.g., for ((:serial b d) (:serial a b c) (:serial c d))
	(let ((series (delete-duplicates (apply #'nconc (nreverse ',dependencies)))))
	    (sort modules
		  #'(lambda (m1 m2)
		      (let ((p1 (position m1 series))
			    (p2 (position m2 series)))
			(cond ((and p1 p2)
			       (< p1 p2))
			      (p1 nil)
			      (p2 T)
			      (t (string< m1 m2)))))
		  :key #'module-name))))))
	   
     
(defmacro undefine-system (name &rest ignored)
  `(setf *system-definitions*
       (delete ',name *system-definitions*
	       :key #'system-definition-name)))
