;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Wed Nov 15 20:05:19 2006 +0530 <enometh@net.meer>
;;;   Time-stamp: <06/11/20 17:47:24 madhu>
;;;   Bugs-To: <enometh@net.meer>
;;;   Copyright (C) 2006 Madhu. All Rights ~RESEDA~
;;;
;;;  from layer's pxml build.lisp
;;;
(in-package "CL-USER")

(defun mklib (system &optional (defaults *default-pathname-defaults*))
  "Creates a concatenated fasl file named SYSTEM-library.FASL
from the fasl files of the given mk-defsystem system SYSTEM. The
system should already be compiled. The concatenated file is
written in the DEFAULTS directory. (FASL is the appropriate fasl
pathname-type for the CMUCL system.)"
  (labels ((handle-load-only (component) ;  "Return a list of fasl pathnames"
	     (let* ((source-pathname
		     (mk::component-full-pathname component :source))
		    (binary-pathname
		     (mk::component-full-pathname component :binary))
		    (binary-truename (probe-file binary-pathname))
		    (compilation-required-p
		     (cond (binary-truename
			    (< (file-write-date binary-truename)
			       (file-write-date (truename source-pathname))))
			   (t t))))
	       (restart-case
		   (cerror "Skip this file" "Component ~S is load-only."
			   component)
		 (use-existing ()
		   :test
		   (lambda (condition)
		     (declare (ignore condition))
		     binary-truename)
		   :report
		   (lambda (stream)
		     (format stream "Use already compiled (~:[Current~;Out of Date~]) binary: ~A"
			     compilation-required-p binary-truename))
		   (list binary-truename))
		 (compile-and-use ()
		   :report
		   (lambda (stream)
		     (format stream "Compile ~A to ~A and use that fasl?"
			     source-pathname binary-pathname))
		   (multiple-value-bind (output-truename warnings-p failure-p)
		       (compile-file source-pathname
				     :output-file binary-pathname)
		     (declare (ignore warnings-p))
		     (cond (failure-p
			    (cerror "Skip this file"
				    "Compilation of ~A to produce ~A failed."
				    source-pathname binary-pathname))
			   (t (list output-truename))))))))
	   (walk-components (component)
	     (ecase (mk::component-type component)
	       ((:file :private-file)
		(cond ((mk::component-load-only component)
		       (handle-load-only component))
		      (t (list (mk::component-full-pathname
				component :binary)))))
	       ((:module :system :subsystem :defsystem)
		(loop for x in (mk::component-components component)
		      nconc (walk-components x)))))
	   (handle-deps (system deps)
	     (when deps
	       (restart-case
		   (cerror "Skip deps" "System ~S depends on: ~S" system deps)
		 (recursively-load-deps ()
		   :report "Recursively handle deps"
		   (loop for dep in deps
			 for depsys = (mk:find-system dep)
			 unless depsys
			 do (cerror "OK" "Not handling unknown system: ~S" dep)
			 else nconc (walk-components depsys)))))))
    (let* ((system (etypecase system
		     (mk::component
		      (ecase (mk::component-type system)
			(:defsystem system)))
		     (symbol (mk:find-system system))
		     (string (mk:find-system system))))
	   (deps (mk::component-depends-on system))
	   (fasls (nconc (handle-deps system deps) (walk-components system)))
	   (buf (make-array 2048 :element-type '(unsigned-byte 8)))
	   (pathname (make-pathname
		      :name (concatenate 'string (mk::component-name system)
					 "-library")
		      :type (c:backend-fasl-file-type c:*target-backend*)
		      #+nil(pathname-type (compile-file-pathname "foo"))
		      :version :newest
		      :defaults (pathname defaults))))
      (with-open-file (out pathname :element-type '(unsigned-byte 8)
			   :direction :output :if-exists :supersede
			   :if-does-not-exist :create)
	(loop for file in fasls do
	      (restart-case
		  (with-open-file (in (truename file)
				      :element-type '(unsigned-byte 8))
		    (format t "~%; ~s" file)
		    (loop as x = (read-sequence buf in)
			  until (= x 0)
			  do (write-sequence buf out :end x)))
		(skip-this-file () :report "Skip this file")))
	pathname))))

#+nil
(let ((*default-pathname-defaults* #p"/tmp/"))
  (mklib :weyl))