thodg/cl-unix-cybernetics

diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..81d592b
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,18 @@
+
+PROGRAM = build/adams
+PREFIX = /usr/local
+LISP = sbcl
+LISP_LOAD = ${LISP} --load
+
+all: ${PROGRAM}
+
+${PROGRAM}: build.lisp
+	LANG=C.UTF-8 ${LISP_LOAD} build.lisp
+
+clean:
+	rm -rf build/*
+
+install: ${PROGRAM}
+	install -m 0755 ${PROGRAM} ${PREFIX}/bin
+
+.PHONY: all clean install ${PROGRAM}
diff --git a/build.lisp b/build.lisp
new file mode 100644
index 0000000..b29abf7
--- /dev/null
+++ b/build.lisp
@@ -0,0 +1,103 @@
+
+(in-package :common-lisp-user)
+
+(defgeneric collect-sources (x))
+
+(defmethod collect-sources ((x symbol))
+  (collect-sources (asdf:find-system x)))
+
+(defmethod collect-sources ((x string))
+  (collect-sources (asdf:find-system x)))
+
+(defun sort-components (list)
+  (declare (type list list))
+  (let (components roots)
+    (declare (type list components roots))
+    (labels ((map-dependencies (comp fn)
+               (declare (type asdf:component comp))
+               (dolist (id (asdf:component-sideway-dependencies comp))
+                 (let ((dep (find id list :test #'string=
+                                  :key #'asdf:component-name)))
+                   (when dep
+                     (funcall (the function fn) dep)))))
+             (dfs (comp)
+               (declare (type asdf:component comp))
+               (map-dependencies comp #'dfs)
+               (pushnew comp components)))
+      (dolist (comp list)
+        (declare (type asdf:component comp))
+        (pushnew comp roots))
+      (dolist (comp list)
+        (declare (type asdf:component comp))
+        (map-dependencies comp (lambda (dep)
+                                 (setf roots (delete dep roots)))))
+      (dolist (comp roots)
+        (dfs comp)))
+    (nreverse components)))
+
+(defmethod collect-sources ((x asdf:parent-component))
+  (let ((children (sort-components (asdf:component-children x))))
+    (mapcan #'collect-sources children)))
+
+(defmethod collect-sources ((req asdf:require-system))
+  (list `(require ,(string-upcase (asdf:component-name req)))))
+
+(defmethod collect-sources ((x asdf:cl-source-file))
+  (list `(load (compile-file ,(asdf:component-pathname x)))))
+
+(defmethod collect-sources ((x asdf:file-component))
+  (list `(quote ,(asdf:component-pathname x))))
+
+(defmethod collect-sources :around ((x asdf:component))
+  (let ((if-feature (asdf::component-if-feature x)))
+    (if if-feature
+        (when (find (the symbol if-feature) *features*)
+          (call-next-method))
+        (call-next-method))))
+
+#+nil (collect-sources :adams)
+
+(defun system-and-dependencies (name)
+  (let (dependencies)
+    (labels ((dfs (name)
+               (let ((sys (asdf:find-system name)))
+                 (when sys
+                   (locally (declare (type asdf:system sys))
+                     (map 'nil #'dfs (asdf:system-depends-on sys))
+                     (pushnew sys dependencies))))))
+      (dfs name)
+      (nreverse dependencies))))
+
+(defun system-directory (system)
+  (unless (typep system 'asdf:system)
+    (setq system (asdf:find-system system)))
+  (make-pathname :name nil
+                 :type nil
+                 :defaults (asdf:system-source-file system)))
+
+(defun system-file (system &rest parts)
+  (let ((str (apply #'concatenate 'string parts)))
+    (merge-pathnames str (system-directory system))))
+
+(defun build/systems.lisp (system)
+  (unless (typep system 'asdf:system)
+    (setq system (asdf:find-system system)))
+  (let* ((path (system-file system "build/systems.lisp")))
+    (print path) (force-output)
+    (ensure-directories-exist path)
+    (with-open-file (out path :direction :output
+                         :element-type 'character
+                         :external-format :utf-8
+                         :if-exists :overwrite
+                         :if-does-not-exist :create)
+      (declare (type stream out))
+      (dolist (sys (system-and-dependencies system))
+        (let ((sys-name (asdf:component-name sys)))
+          (format t "~& ~A~%" sys) (force-output)
+          (format out "~&;;  ~A" sys-name))
+        (dolist (src (collect-sources sys))
+          (print src out))))))
+
+(build/systems.lisp :adams)
+(load (system-file :adams "build/systems.lisp"))
+(load (system-file :adams "toplevel.lisp"))
diff --git a/toplevel.lisp b/toplevel.lisp
new file mode 100644
index 0000000..e3bd1af
--- /dev/null
+++ b/toplevel.lisp
@@ -0,0 +1,27 @@
+;;
+;;  adams  -  Remote system administration tools
+;;
+;;  Copyright 2013,2014 Thomas de Grivel <thomas@lowh.net>
+;;
+;;  Permission to use, copy, modify, and distribute this software for any
+;;  purpose with or without fee is hereby granted, provided that the above
+;;  copyright notice and this permission notice appear in all copies.
+;;
+;;  THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
+;;  WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
+;;  MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
+;;  ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
+;;  WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
+;;  ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
+;;  OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
+;;
+
+(in-package :adams)
+
+(defun adams-toplevel ()
+  (let ((*package* (find-package :adams-user)))
+    (sb-impl::toplevel-init)))
+
+(sb-ext:save-lisp-and-die #P"~/common-lisp/cl-adams/adams/build/adams"
+                          :toplevel #'adams-toplevel
+                          :executable t)