;;; -*- Mode: LISP; Package: :cl-user; BASE: 10; Syntax: ANSI-Common-Lisp; -*-
;;;
;;;   Touched: Sat Jun 16 06:06:51 2007 +0530 <enometh@net.meer>
;;;   Time-stamp: <2007-09-24 16:28:54 madhu>
;;;   Bugs-To: <enometh@net.meer>
;;;   Status: Experimental.  Do not Redistribute.
;;;   Copyright (C) 2007 Madhu.  All Rights Reserved.
;;;
(defpackage "BUILD-CMUCL-1-1"
  (:use "CL"))
(in-package "BUILD-CMUCL-1-1")

;;; ----------------------------------------------------------------------
;;;
;;;
(defvar *CVSROOT-CMUCL*
  (or #+rhea #p"/scratch/madhu/extern/CVS-cmucl/cvsroot/"
      #p"/mnt/scratch/src/CVS-cmucl/cvsroot/"))

(defun directory-pathname (root &rest dircomps)
  "Tag directory components DIRCOMPS at the end of pathname ROOT."
  (make-pathname :name nil :type nil :version nil
		 :directory (append (pathname-directory root) dircomps)
		 :defaults root))


;;; ----------------------------------------------------------------------
;;;
;;; HISTORY FROBBING UTILS
;;;

(defun history-file-pathname ()
  (make-pathname :name "history" :type nil :version nil
		 :defaults (directory-pathname *CVSROOT-CMUCL* "CVSROOT")))

(defun parse-history-line (line &key (start 0) end)
  "Return a list of  (X date  user CurDir Repository  rev(s) argument."
  (let ((X (char line start)))
    (ecase X ((#\T #\O #\E #\F #\W #\U #\P #\G #\C #\M #\A #\R)))
    (let ((pos (position #\| line :start (1+ start) :end end)))
      (assert (= pos (+ start 1 8)))
      (let ((hexdate
	     (+ USER::+UNIX-EPOCH+
		(parse-integer line :start (1+ start) :end (+ 8 1 start)
			       :radix 16))))
	(list* X hexdate (user::string-split #\| line :start (1+ pos)
					     :end end))))))

#||
(parse-history-line "M452116e7|rtoy|<remote>|src/code|1.36|ntrace.lisp")
(parse-history-line "O32f7b7b3|pw|<remote>/*0|src||src")
||#

#||
(user:lc "home:cl/mytrie")
(user:lc "home:clisp/mytrie")
(user:lc "cmu/treap")
(user:lc "home:cl/treap")
(user:lc "home:cmu/cvslib.l")
(user:lc "home:cl/cvslib.l")
(user:lc "cl/date-time")
(user:lc "home:cmu/date-time")
||#

(defvar *user-trie* (trie:make-trie))
(defvar *filename-trie* (trie:make-trie))
(defvar *revs-trie* (trie:make-trie))
(defvar *file-table* (make-hash-table :test #'eq))

(defun assoc-filename-revision-lineno (filename revision lineno)
  "Mutates *file-table*."
  (let ((revision-alist (gethash filename *file-table*)))
    (cond (revision-alist
	   (let ((linenos (assoc revision revision-alist)))
	     (cond (linenos
		    (unless (find lineno (cdr linenos))
		      (warn "~A: ~A: duplicate entry on line ~A." filename
			    revision lineno)
		      (user::pushnew-ordered lineno (cdr linenos) '>)))
		   (t (user::pushnew-ordered
		       (list revision lineno) revision-alist '< :key #'cadr)
		      (setf (gethash filename *file-table*) revision-alist)))))
	  (t (setf (gethash filename *file-table*)
		   (list (list revision lineno)))))))

(defun parse-commit-line (line &optional lineno)
  "Returns a list of (X file-pathname revision date author)."
  (destructuring-bind  (X date user CurDir Repository revs arg)
      (parse-history-line line)
    (declare (ignore curdir))
    (ecase X ((#\M #\A #\R)))
    (let ((username (trie:intern-string user :strings-trie *user-trie*))
	  (revision (trie:intern-string revs :strings-trie *revs-trie*))
	  (filename (trie:intern-string
		     (concatenate 'string Repository "/" arg)
		     :strings-trie *filename-trie*)))
      (when lineno
	(assoc-filename-revision-lineno filename revision lineno))
      (list X filename revision date username))))

(defvar *commit-lines* (make-hash-table)
  "Parsed commit lines indexed by lineno")

(defvar *commit-treap* (treap:make-treap)
  "Linenos indexed by utime.")

(defun process-commit-line (line lineno)
  "Keep track of commits."
  (let ((X (char line 0)))
    (ecase X
      ((#\T #\O #\E #\F #\W #\U #\G #\C #\P)
       #+NIL
       (warn "Ignoring line: ~@[~A: ~]~@[~A~]" lineno #+XXX line nil))
      ((#\M #\A #\R)
       (destructuring-bind (X filename revision date username)
	   (setf (gethash lineno *commit-lines*)
		 (parse-commit-line line lineno))
	 (declare (ignore X revision username))
	 (if (and (> (length filename) 2)
		  (eql (aref filename 0) #\s)
		  (eql (aref filename 1) #\r)
		  (eql (aref filename 2) #\c))
	     (user::pushnew-ordered
	      lineno
	      (treap:gettreap date *commit-treap*) '<)))))))

#+NIL
(with-open-file (stream (history-file-pathname))
  (loop for lineno from 1
	for line = (read-line stream nil nil)
	while line do (process-commit-line line lineno)))

#||
(parse-commit-line "M452116e7|rtoy|<remote>|src/code|1.36|ntrace.lisp")
(defun trie-complete-strings (trie)
    (mapcar (lambda (x) (coerce x 'string)) (trie:trie-completions trie)))
(trie-complete-strings *user-trie*)
(length (trie-complete-strings *filename-trie*))
(trie::trie-count *filename-trie*)
*file-table*
(treap:treap-length *commit-treap*)
(gethash 5819 *commit-lines*)
(second (gethash 5819 *commit-lines*))
(gethash (second (gethash 5819 *commit-lines*)) *file-table*)
(multiple-value-setq ($lo $hi)
  (values-list
   (mapcar
    (lambda (x)
      (make-instance 'date-time:date-time :utime x :tz 0))
    (treap:treap-find-bounds
     *commit-treap*
     (date-time:utime
      (make-instance 'date-time:date-time :year 2006 :month 3 :date 31
		     :hour 0 :minute 0 :second 0 :time-zone 0 ))))))
(treap:gettreap (date-time:utime $lo) *commit-treap*)
(treap:gettreap (date-time:utime $hi) *commit-treap*)
(parse-history-line "M452116e7|rtoy|<remote>|src/code|1.36|ntrace.lisp")
(parse-history-line "O32f7b7b3|pw|<remote>/*0|src||src")
(parse-commit-line "M452116e7|rtoy|<remote>|src/code|1.36|ntrace.lisp")
||#


;;; ----------------------------------------------------------------------
;;;
;;; UTILS
;;;

(defun date-spec (utime)
  (user:iso-8601-date :utime utime :stream nil :tz 0 :suppress-tz-p nil))

(defun scrub-spaces (string)
  (substitute #\_ #\Space string))

(defun tag-operation (stream &rest strings)
  "Without any STRING arguments, assumes completion of USER:*LAST-COMMAND*."
  (format stream "~%~%~%--MADHU--")
  (user:date :stream stream)
  (if strings
      (progn (format stream "--~{~A--~}~%~%~%" strings)
	     (finish-output stream))
      (let ((status (ext:process-status user::*process*))
	    (exit-code (ext:process-exit-code user::*process*)))
	(format stream "-- COMPLETED:  \"~{~A~^ ~A ~}\"~%~%~%"
		user::*last-command*)
	(finish-output stream)
	(ecase status
	  (:exited
	   (unless (zerop exit-code)
	     (cerror "Continue"
		     "~A aborted with an error." user::*last-command*)))
	  (:signaled
	   (cerror "Continue"
		   "~A killed with signal ~A~@[ (core dumped)~]."
		   user::*last-command* exit-code
		   (ext:process-core-dumped user::*process*)))))))

(defun build-binary-command-1 (build-binary-root)
  "BUILD-BINARY-ROOT is an [absolute] pathname to the root of an
unpacked distribution."
  (format nil "~A -core ~A -noinit -nositeinit"
	  (namestring
	   (make-pathname
	    :name "lisp" :type nil :version nil
	    :defaults (directory-pathname build-binary-root "bin")))
	  (namestring
	   (make-pathname
	    :name "lisp" :type "core" :version nil
	    :defaults (directory-pathname
		       build-binary-root "lib" "cmucl" "lib")))))

(defun build-binary-command-2 (build-binary-root)
  "BUILD-BINARY-ROOT is an [absolute] pathname to the root of a CMUCL build."
  (format nil "~A -core ~A -noinit -nositeinit"
	  (namestring
	   (make-pathname
	    :name "lisp" :type nil :version nil
	    :defaults (directory-pathname build-binary-root "lisp")))
	  (namestring
	   (make-pathname
	    :name "lisp" :type "core" :version nil
	    :defaults (directory-pathname build-binary-root "lisp")))))

(defun get-cvs-timestamp (source-tree)
  "Return a string denoting date of the latest file in the checked out
tree. This function examines CVS Entries files. The date is produced by ISO C
asctime() under UTC."
  (destructuring-bind (entry pathname)
      (cvslib:find-oldest-cvs-entry source-tree #'>)
    (declare (ignore pathname))
    (getf entry :timestamp)))

(defun get-cvs-tag-line (source-tree)
  "Return the contents of the `Tag' file in the checked out tree."
  (let ((tag-file-pathname
	 (make-pathname :name "Tag" :version nil :type nil
			:defaults (directory-pathname source-tree "CVS"))))
    (when (probe-file tag-file-pathname)
      (with-open-file (stream tag-file-pathname)
	(read-line stream)))))

(defun version-name-1 (source-tree)
  (let ((stamp (get-cvs-timestamp source-tree))
	(tagline (get-cvs-tag-line source-tree)))
    (when stamp
      (with-output-to-string (stream)
	(write-string "CVS files of " stream)
	(write-string stamp stream)
	(when tagline
	  (let ((char (aref tagline 0)))
	    (ecase char
	      (#\D (write-string " tagged on " stream))
	      (#\N (write-string " tagged as " stream))
	      (#\T (write-string " on branch " stream)))
	    (write-string tagline stream :start 1)))))))


;;; ----------------------------------------------------------------------
;;;
;;; BUILDING LOCATIONS:
;;;
(defvar *SCRATCH-ROOT*
  (or #+rhea
      #p"/scratch/madhu/build/cmucl/"
      #p"/var/local/build/cmucl/"))

(defvar $cmurootdir nil)
(defvar $cmusrcdir nil)
(defvar $cmubuilddir nil)

(defvar $targetsubdir "glibc22")
(defvar $xbuildsubdir "xbuild")

(defun setup (subdirname &optional)
  (setq $cmurootdir (directory-pathname *scratch-root* subdirname)
	$cmusrcdir (directory-pathname $cmurootdir "src")
	$cmubuilddir (directory-pathname $cmurootdir $targetsubdir))
  (values $cmurootdir $cmusrcdir $cmubuilddir))

(defun cmucheckout (&rest args-to-checkout)
  "Checks out a module named `src' in $cmurootdir."
  (user:in-directory $cmurootdir
    (with-open-file (stream "cvs.out"
			    :if-does-not-exist :create
			    :direction :output
			    :if-exists :append)
      (tag-operation stream "CHECKOUT")
      (user:with-defaults (:output stream)
	  (apply #'user:run2
		 "cvs" "-d" (LISP::DIRECTORY-NAMESTRING *CVSROOT-CMUCL*)
		 "co" (append args-to-checkout '("src"))))
      (tag-operation stream))))

(defun create-target (targetsubdir &rest args-to-create-target)
  (user:in-directory $cmurootdir
    (with-open-file (stream "build.out"
			    :if-does-not-exist :create
			    :direction :output
			    :if-exists :append)
      (tag-operation stream "CREATE-TARGET")
      (user:with-defaults (:output stream)
	(apply #'user:run2 "src/tools/create-target.sh"
	       targetsubdir args-to-create-target))
      (tag-operation stream))))

(defun build-world (&rest args-to-build-world)
  (user:in-directory $cmurootdir
    (with-open-file (stream "build.out"
			    :if-does-not-exist :create
			    :direction :output
			    :if-exists :append)
      (tag-operation stream "BUILD-WORLD")
      (user:with-defaults (:output stream)
	(apply #'user:run2 "src/tools/build-world.sh"
	       $targetsubdir args-to-build-world))
      (tag-operation stream))))

(defun cross-build-world (&rest args-to-xbuild-world)
  (user:in-directory $cmurootdir
    (with-open-file (stream "build.out"
			    :if-does-not-exist :create
			    :direction :output
			    :if-exists :append)
      (tag-operation stream "CROSS-BUILD-WORLD")
      (user:with-defaults (:output stream)
	(apply #'user:run2 "src/tools/cross-build-world.sh"
	       $targetsubdir $xbuildsubdir args-to-xbuild-world))
      (tag-operation stream))))

(defun rebuild-lisp (&rest args-to-rebuild-lisp)
  (user:in-directory $cmurootdir
    (with-open-file (stream "build.out"
			    :if-does-not-exist :create
			    :direction :output
			    :if-exists :append)
      (tag-operation stream "REBUILD-LISP")
      (user:with-defaults (:output stream)
	(apply #'user:run2 "src/tools/rebuild-lisp.sh"
	       $targetsubdir args-to-rebuild-lisp))
      (tag-operation stream))))

(defun load-world (&rest args-to-load-world)
  (user:in-directory $cmurootdir
    (with-open-file (stream "build.out"
			    :if-does-not-exist :create
			    :direction :output
			    :if-exists :append)
      (tag-operation stream "LOAD-WORLD")
      (user:with-defaults (:output stream)
	(apply #'user:run2 "src/tools/load-world.sh"
	       $targetsubdir args-to-load-world))
      (tag-operation stream))))


;;; ----------------------------------------------------------------------
;;;
;;;
;;;
(defvar $utime nil)
(defvar $build-binary-command nil)
(defvar $cvstagname nil)
(defvar $bootfile nil)
(defvar $xbuildp nil)
(defvar $subdirname nil)

(defun $build ()
  "If UTIME and CVSTAG are both NIL no checkout is performed. If XBUILDP
is non-NIL, BOOTFILE must be a cross-compile script."
(setq $subdirname
      (if $utime
	  (if $cvstagname
	      (concatenate 'string $cvstagname "_"
			   (scrub-spaces (date-spec $utime)))
	      (scrub-spaces (date-spec $utime)))
	  (if $cvstagname $cvstagname)))
(when $subdirname
(setup $subdirname)
(ensure-directories-exist $cmurootdir :verbose t))
(if $utime
    (if $cvstagname
	(cmucheckout "-r" $cvstagname "-D" (date-spec $utime))
	(cmucheckout "-D" (date-spec $utime)))
    (if $cvstagname (cmucheckout "-r" $cvstagname)))
(create-target $targetsubdir)
(cond ($xbuildp
       (create-target $xbuildsubdir)
       (assert $bootfile)
       (cross-build-world $bootfile $build-binary-command))
      ($bootfile
       (build-world $build-binary-command "-load" $bootfile))
      (t (build-world $build-binary-command)))
(rebuild-lisp)
(cond ($xbuildp
       (create-target $xbuildsubdir)
       (assert $bootfile)
       (cross-build-world $bootfile $build-binary-command))
      ($bootfile
       (build-world $build-binary-command "-load" $bootfile))
      (t (build-world $build-binary-command)))
(if $xbuildp (fix-load-world.sh t))	;; add :no-pcl
(load-world (concatenate 'string (version-name-1 $cmusrcdir)))
(if $xbuildp (fix-load-world.sh nil))	;; revive :no-pcl
)

(defun fix-load-world.sh (nopcl-p)	; FIXME
  (user:in-directory $cmurootdir
    (cond (nopcl-p
	   (assert (not (probe-file "src/tools/load-world.sh.Orig")))
	   (assert (probe-file "src/tools/load-world.sh"))
	   (rename-file "src/tools/load-world.sh"
			"load-world.sh.Orig" #+nil ; XXX ???
			"src/tools/load-world.sh.Orig")
	   (user:with-defaults ()
	     (user:run2 "cp" "-apiv"
			"/nfs/guest/madhu/cmu/cmucl-build/dd/tools/load-world.sh"
			"src/tools/load-world.sh")))
	  (t (assert (probe-file "src/tools/load-world.sh.Orig"))
	     (assert (probe-file "src/tools/load-world.sh"))
	     (delete-file "src/tools/load-world.sh")
	     (rename-file "src/tools/load-world.sh.Orig"
			  "load-world.sh" #+nil ; XXX ???
			  "src/tools/load-world.sh")))))

#||
(setq $build-binary-command
      (build-binary-command-1 #p"/scratch/madhu/cmucl-2006-03-31-robolove/"))
(setq $utime 3351647869 $cvstagname nil $xbuildp nil $bootfile nil)
($build)

(setq $build-binary-command (build-binary-command-2 $builddir))
(setq $cvstagname "snapshot-2006-06" $utime nil $xbuildp nil $bootfile nil)
($build)

(get-cvs-tag-line $cmusrcdir)
(get-cvs-timestamp $cmusrcdir)
(version-name-1 $cmusrcdir)
(cvslib:find-oldest-cvs-entry $cmusrcdir #'>)
(user:string-split #\. (get-cvs-tag-line $cmusrcdir) :start 1)
(version-name-1 $cmusrcdir)
(get-cvs-tag-line $cmusrcdir)
(make-instance 'date-time:date-time :utime  3351774442 :time-zone 6)
(setq $utime
      (date-time:utime
       (make-instance 'date-time:date-time :year 2006 :month 6 :date 1
		      :hour 0 :minute 0 :second 0 :time-zone 0)))
(date-spec $utime)
(let ((*build-binary-command* nil)
      (*build-binary-root* "/var/local/cmucl/"))
  (build-binary-command))
(mapcar
 (lambda (x) (make-instance 'date-time:date-time :utime x :tz 0)
	 (date-spec x))
 (treap:treap-find-bounds
  *commit-treap*
  (date-time:utime
   (make-instance 'date-time:date-time :year 2006 :month 3 :date 31))))
(scrub-spaces (date-spec (get-universal-time)))
||#