#!/usr/bin/guile \
-e main -s
!#
;;; Copyright (C) 2006 Alfredo Beaumont Sainz <alfredo.beaumont@gmail.com>
;;; beebs is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.

;;; beebs is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.

;;; You should have received a copy of the GNU General Public License
;;; along with stut; if not, write to the Free Software
;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

(use-modules (ice-9 popen))
(use-modules (ice-9 expect))
(use-modules (ice-9 regex))

(define (drain-output port)
  (let loop ((chars '())
             (next (read-char port)))
    (if (eof-object? next)
        (list->string (reverse! chars))
        (loop (cons next chars)
              (read-char port)))))

(define target "i586-pc-gnu")
(define log-file "beebs.log")
(define sources-directory "src")
(define builds-directory "obj")
(define prefix (string-append (getcwd) "/bee"))
(define environment (string-append "unset LD_LIBRARY_PATH; PATH=" prefix "/bin:$PATH "))
(define sys-root (string-append prefix "/sysroot"))
(define default-repo ":pserver:anoncvs@cvs.savannah.gnu.org:/cvsroot/hurd")
(define default-branch "HEAD")
(define default-cross-opts (string-append " --target=" target " --prefix=" prefix))
(define default-opts (string-append " --host=" target " --prefix="))
(define default-make " all install")
(define binutils-repo ":pserver:anoncvs@sourceware.org:/cvs/src")
(define binutils-branch "binutils-2_16-branch")
(define binutils-modname "src")
(define binutils-opts (string-append default-cross-opts " --with-sysroot=" sys-root " --disable-nls"))
(define gcc-repo ":pserver:anoncvs@cvs.savannah.gnu.org:/cvsroot/gcc")
(define gcc-branch "gcc-3_3-branch")
(define minimal-gcc-opts (string-append binutils-opts " --disable-shared --without-headers --with-newlib --enable-languages=c"))
(define minimal-gcc-premake (lambda ()
							  (touch (string-append sys-root "/include/signal.h"))
							  (make-directory (string-append sys-root "/include/sys"))
							  (touch (string-append sys-root "/include/sys/ucontext.h"))))
(define minimal-gcc-make " all-gcc install-gcc")
(define minimal-gcc-postmake (lambda ()
							   (make-directory (string-append sys-root "/lib"))
							   (touch (string-append sys-root "/lib/libgcc_eh.a"))
							   (delete-file "config.status")
							   (delete-file (string-append sys-root "/include/signal.h"))
							   (delete-file (string-append sys-root "/include/sys/ucontext.h"))))
(define gnumach-branch "gnumach-1-branch")
(define gnumach-make (string-append " prefix=" sys-root " no_deps=t install-headers"))
(define mig-opts default-cross-opts)
(define hurd-preopts "CC=gcc ")
(define hurd-opts (string-append default-opts " --disable-profile"))
(define hurd-make gnumach-make)
(define glibc-repo ":pserver:anoncvs@sources.redhat.com:/cvs/glibc")
(define glibc-branch "glibc-2_3_5")
(define glibc-modname "libc")
(define glibc-build (lambda ()
					  (let* ((pipe (open-input-pipe (string-append sources-directory "/glibc/scripts/config.guess")))
							 (output (drain-output pipe)))
						(close-pipe pipe)
						(substring output 0 (- (string-length output) 1)))))
(define glibc-opts (string-append " --without-cvs --build=" (glibc-build) default-opts " --with-headers=" sys-root "/include --disable-profile --without-tls"))
(define glibc-make (string-append " install_root=" sys-root default-make))
(define glibc-postmake (lambda ()
						 (if (not (access? (string-append sys-root "/lib/ld.so.1") F_OK))
							 (symlink (string-append sys-root "/lib/ld.so") "ld.so.1" ))
						 (delete-file "config.status")))
(define gcc-opts (string-append binutils-opts " --enable-languages=c"))
(define gcc-premake (lambda ()
					  (delete-file (string-append sys-root "/lib/libgcc_eh.a"))))

(define update? #f)
(define verbose 1)


(define (get-module-value module option)
  	   (let ((module-option (string-append module option))
			 (default-option (string-append "default" option)))
			 (if (defined? (string->symbol module-option))
				 (eval-string module-option)
				 (if (defined? (string->symbol default-option))
					 (eval-string default-option)
					 ""))))

(define (module-get-list module-name)
  (let* 
	  ((name-start (string-rindex module-name #\-))
	   (module
		(if name-start
			(substring module-name (+ 1 name-start))
			module-name)))
	(list 
	 (cons 'name module)
	 (cons 'source (string-append sources-directory "/" module))
	 (cons 'build (string-append builds-directory "/" module))
	 (cons 'repo (get-module-value module "-repo"))
	 (cons 'branch (get-module-value module "-branch"))
	 (cons 'modname (get-module-value module "-modname"))
	 (cons 'preopts (get-module-value module "-preopts"))
	 (cons 'opts (get-module-value module-name "-opts"))
	 (cons 'premake (get-module-value module-name "-premake"))
	 (cons 'make (get-module-value module-name "-make"))
	 (cons 'postmake (get-module-value module-name "-postmake")))))

; Call a system command and check result value
(define (system-check cmd)
  (define ret (system (string-append environment cmd)))
	(if (not (zero? ret))
		(begin
		  (write-line (string-append "*** The following command failed: " cmd))
		  (quit ret))))

(define (touch file)
  (close (open file O_CREAT)))

(define (make-directory dir)
  (if (not (access? dir F_OK))
	  (mkdir dir)))
  
(define (make-directories)
  (make-directory sources-directory)
  (make-directory builds-directory))

; Update sources from CVS
; Check for existence of previous repository and, if so, update the sources.
; Otherwise, checkout the module
(define (do-update server branch module)
  (if (> verbose 0)
	  (begin
		(write-line ">> do-update: " log-port)
		(write-line (string-append ">>> (cwd): " (getcwd)) log-port)
		(write-line (string-append ">>> server: " server) log-port)
		(write-line (string-append ">>> branch: " branch) log-port)
		(write-line (string-append ">>> module: " module) log-port)))
  (if update?
	  (if (access? (string-append module "/CVS") F_OK)
		  (begin
			(chdir module)
			(system-check (string-append "cvs -z 9 update -r " branch " " module))
			(chdir "../")
			#f)
		  (begin
			(system-check (string-append "cvs -z 9 -d " server " co -r " branch " " module))
			#t))
	  #f))
  
(define (do-configure preopts sources opts)
  (if (> verbose 0)
	  (begin
		(write-line ">> do-configure: " log-port)
		(write-line (string-append ">>> (cwd): " (getcwd)) log-port)
		(write-line (string-append ">>> preopts: " preopts) log-port)
		(write-line (string-append ">>> sources: " sources) log-port)
		(write-line (string-append ">>> options: " opts) log-port)))
  (if (not (zero? (system "./config.status --version > /dev/null 2>&1")))
	  (begin
		(let ((cmd (string-append preopts "../../" sources "/configure" opts)))
		(system-check cmd)))))

(define (do-make-install make-opts)
  (if (> verbose 0)
	  (begin
		(write-line ">> do-make-install: " log-port)
		(write-line (string-append ">>> (cwd): " (getcwd)) log-port)
		(write-line (string-append ">>> options: " make-opts) log-port)))
  (system-check (string-append "make" make-opts)))

(define (do-toolchain)
  (do ((module-list (list 'binutils 'minimal-gcc 'gnumach 'mig 'hurd 'glibc 'gcc 'glibc) (cdr module-list)))
	  ((null? module-list))
	(let* ((module (car module-list))
		   (module-string (symbol->string module))
		   (option-list (module-get-list module-string))
		   (name     (cdr (assq 'name     option-list)))
		   (source   (cdr (assq 'source   option-list)))
		   (build    (cdr (assq 'build    option-list)))
		   (repo     (cdr (assq 'repo     option-list)))
		   (branch   (cdr (assq 'branch   option-list)))
		   (modname  (cdr (assq 'modname  option-list)))
		   (preopts  (cdr (assq 'preopts  option-list)))
		   (opts     (cdr (assq 'opts     option-list)))
		   (premake  (cdr (assq 'premake  option-list)))
		   (make     (cdr (assq 'make     option-list)))
		   (postmake (cdr (assq 'postmake option-list))))
	  (chdir sources-directory)
	  (if (and (do-update repo branch name) (not (string-null? modname)))
			(rename-file modname name))
	  (chdir "../")
	  (make-directory build)
	  (chdir build)
	  (do-configure preopts source opts)
	  (if (not (string? premake))
		  (begin
			(if (> verbose 0)
				(begin
				  (write-line ">> premake: " log-port)
				  (write-line (string-append ">>> (cwd): " (getcwd)) log-port)
				  (write-line (string-append ">>> code: " (object->string (procedure-source premake))) log-port)))
			(premake)))
	  (do-make-install make)
	  (if (not (string? postmake))
		  (begin
			(if (> verbose 0)
				(begin
				  (write-line ">> postmake: " log-port)
				  (write-line (string-append ">>> (cwd): " (getcwd)) log-port)
				  (write-line (string-append ">>> code: " (object->string (procedure-source postmake))) log-port)))
			(postmake)))
	  (chdir "../../"))))

(define log-port 
  (if (> verbose 0)
	  (open-output-file log-file)))

(define (main args)
  (make-directories)
  (do-toolchain)
  (close log-port))