first commit

.gitignore

@@ -0,0 +1,2 @@
+/fb
+.*.swp

example/.gitignore

@@ -0,0 +1 @@
+/build

example/fancy.build

@@ -0,0 +1,140 @@
+(in-package :fancybuild)
+
+(defun runp (cmd)
+  (assert (zerop (uiop:wait-process (uiop:launch-program cmd :output *standard-output* :error-output *error-output*)))))
+
+(defun target (name target)
+  (setf (gethash name *targets*) target))
+
+(defun mtime (x) (osicat-posix:stat-mtime (osicat-posix:stat x)))
+; todo blake3?
+(defun sha256 (fn)
+  (with-open-file (fp fn
+                      :direction :input
+                      :if-does-not-exist :error
+                      :element-type '(unsigned-byte 8))
+    (let ((buf (make-array (file-length fp) :element-type '(unsigned-byte 8))))
+      (read-sequence buf fp)
+      (ironclad:digest-sequence :sha256 buf))))
+
+(defun any (pred &rest lis)
+  (if (null (car lis))
+    nil
+    (or (apply pred (mapcar #'car lis))
+        (apply #'any (cons pred (mapcar #'cdr lis))))))
+(defun all (pred &rest lis)
+  (if (null (car lis))
+    t
+    (and (apply pred (mapcar #'car lis))
+         (apply #'all (cons pred (mapcar #'cdr lis))))))
+
+(defparameter *file-change-watchers* (make-hash-table :test #'equal))
+
+(defclass file-change-watcher ()
+  ((fpath :initarg :fpath)
+   (hash :initform nil)
+   (mtime :initform 0)))
+
+(defmethod freeze ((f file-change-watcher))
+  (setf (slot-value f 'hash) (sha256 (slot-value f 'fpath)))
+  (setf (slot-value f 'mtime) (mtime (slot-value f 'fpath)))
+  t)
+
+(defmethod file-changed ((f file-change-watcher))
+  (and (not (= (mtime (slot-value f 'fpath)) (slot-value f 'mtime)))
+       (not (equalp (sha256 (slot-value f 'fpath)) (slot-value f 'hash)))))
+
+(defun get-file-watcher (fpath purpose)
+  (let ((key (cons fpath purpose)))
+    (unless (gethash key *file-change-watchers*)
+      (setf (gethash key *file-change-watchers*)
+            (make-instance 'file-change-watcher :fpath fpath)))
+    (gethash key *file-change-watchers*)))
+
+; Rebuild whenever any of the output files doesn't exist
+; Or, whenever any of the input files has a newer mtime than any of the output files
+;  (that is, whenever the newest input file is newer than the oldest output file)
+; Or, whenever any of the input files has been modified
+(defclass rebuilt-on-change (buildable)
+  ((input-files :initarg :input-files :initform nil)
+   (input-objs)
+   (output-files :initarg :output-files :initform nil)
+   (purpose :initarg :purpose :initform nil)
+   (cached-snapshot :initform t)))
+
+(defmethod rebuild-change-init ((b rebuilt-on-change))
+  (setf (slot-value b 'input-objs)
+        (mapcar #'(lambda (x) (get-file-watcher x (slot-value b 'purpose))) (slot-value b 'input-files))))
+
+(defmethod snapshot ((b rebuilt-on-change))
+  (mapcar #'freeze (slot-value b 'input-objs))
+  t)
+
+(defmethod is-dirty ((b rebuilt-on-change) old)
+  (or (not (any #'probe-file (slot-value b 'output-files)))
+      (any #'file-changed (slot-value b 'input-objs))))
+
+(defclass c-source-buildable (rebuilt-on-change)
+  ((source-file :initarg :source-file)
+   (obj-file :initarg :obj-file)))
+
+(defclass c-binary-buildable (rebuilt-on-change)
+  ((target-binary :initarg :target-binary)
+   (obj-files)))
+
+(defmethod initialize-instance :after ((b c-binary-buildable) &key)
+  (setf (slot-value b 'obj-files) (mapcar #'(lambda (x) (slot-value x 'obj-file)) (remove-if-not #'(lambda (x) (typep x 'c-source-buildable)) (slot-value b 'dependencies))))
+  (setf (slot-value b 'input-files) (slot-value b 'obj-files))
+  (setf (slot-value b 'output-files) (list (slot-value b 'target-binary)))
+  (setf (slot-value b 'pretty-name) (slot-value b 'target-binary))
+  (setf (slot-value b 'purpose) 'c-binary-build)
+  (setf (slot-value b 'unique-key) (cons 'c-binary-buildable (cons (slot-value b 'target-binary) (slot-value b 'obj-files))))
+  (rebuild-change-init b))
+
+(defmethod do-build ((b c-binary-buildable))
+  (runp (format nil "cc -o ~a ~{~a~^ ~}" (slot-value b 'target-binary) (slot-value b 'obj-files))))
+
+(defmethod initialize-instance :after ((b c-source-buildable) &key)
+  (setf (slot-value b 'input-files) (list (slot-value b 'source-file)))
+  (setf (slot-value b 'output-files) (list (slot-value b 'obj-file)))
+  (setf (slot-value b 'pretty-name) (slot-value b 'source-file))
+  (setf (slot-value b 'purpose) 'c-source-build)
+  (setf (slot-value b 'unique-key) (list 'c-source-buildable (slot-value b 'obj-file) (slot-value b 'source-file)))
+  (rebuild-change-init b))
+
+(defmethod do-build ((b c-source-buildable))
+  (ensure-directories-exist (directory-namestring (slot-value b 'obj-file)))
+  (runp (format nil "cc -c -o ~a ~a" (slot-value b 'obj-file) (slot-value b 'source-file))))
+
+(defun c-source (file)
+  (make-instance 'c-source-buildable
+                 :source-file file
+                 :obj-file (format nil "build/~a.o" file)))
+(defun c-sourcelist (srclist)
+  (mapcar #'c-source srclist))
+;(c-sourcelist srclist)
+
+(defun c-binary (bin deps)
+  (make-instance 'c-binary-buildable
+                 :target-binary (format nil "build/~a" bin)
+                 :dependencies deps))
+
+(defparameter *t1*
+  (c-binary "test"
+            (c-sourcelist '("src/add.c" "src/test.c"))))
+(defparameter *t2*
+  (c-binary "test2"
+            (c-sourcelist '("src/add.c" "src/test2.c"))))
+
+;(defparameter x (make-instance 'c-source-buildable
+;                               :source-file "test/test.c"
+;                               :obj-file "build/test/test.o"))
+;(defparameter y (make-instance 'c-source-buildable
+;                               :source-file "test/add.c"
+;                               :obj-file "build/test/add.o"))
+;(defparameter z (make-instance 'c-binary-buildable
+;                               :target-binary "build/test/test"
+;                               :dependencies (list x y)))
+
+(target "default" *t1*)
+(target "other" *t2*)

example/src/add.c

@@ -0,0 +1 @@
+int add(int x, int y) { return x + y; }

example/src/test.c

@@ -0,0 +1,4 @@
+int add(int,int);
+int main(void) {
+	return add(5, 7);
+}

example/src/test2.c

@@ -0,0 +1,4 @@
+int add(int,int);
+int main(void) {
+	return add(5, 9);
+}

fb.asd

@@ -0,0 +1,34 @@
+(defpackage #:fb
+  (:use :cl :asdf))
+
+(defsystem "fb"
+    :name "Fancy Build"
+    ;:serial nil
+    :pathname "src/"
+
+    :depends-on (#:osicat #:ironclad)
+
+    :components ((:file "dependable")
+		 (:file "fb-entry" :depends-on ("dependable")))
+		 ;(:file "x" :depends-on ("y" "z"))
+
+    :build-pathname "fb"
+    :entry-point "fancybuild:main")
+
+
+;#+sb-core-compression
+;(defmethod asdf:perform ((o asdf:image-op) (c asdf:system))
+;  (uiop:dump-image (asdf:output-file o c) :executable t :compression t))
+
+(defsystem "fb/release"
+    :depends-on (:fb)
+
+    :entry-point "fancybuild:main"
+    :build-pathname "fb"
+    :build-operation "asdf:program-op")
+
+(defsystem "fb/image"
+    :depends-on (:fb)
+
+    :build-pathname "fb"
+    :build-operation "asdf:image-op")

magic

@@ -0,0 +1,11 @@
+#!/bin/sh
+
+#lisp=ccl
+lisp=sbcl
+
+case $1 in
+	run) rlwrap $lisp --eval "(require :asdf)" --eval "(asdf:load-system :fb)" --eval "(in-package :fancybuild)" --eval "(defun reload () (asdf:load-system :fb) (main))" --eval "(main)" ;;
+	image) $lisp --eval "(require :asdf)" --eval "(asdf:make :fb/image)" ;;
+	build) $lisp --eval "(require :asdf)" --eval "(asdf:make :fb/release)" ;;
+	*) echo "Usage: $0 <run|image|build>"; exit 1
+esac

src/dependable.lisp

@@ -0,0 +1,100 @@
+(defpackage #:fancybuild
+  (:use #:cl)
+  (:export #:main))
+
+; to do the 'test' target:
+;  - build the 'mocc' target
+;  AND THEN
+;  - run the file './aux/run-tests', failing iff it returns non-zero
+
+; to do the 'mocc' target:
+;  - build the 'libmocl.a' target
+;  - build the 'src/buf.c' target
+;  - build the 'src/tok.c' target
+;  - build the 'src/parse.c' target
+;  AND THEN
+;  - run 'cc -o build/mocc build/cl/libmocl.a build/src/buf.o build/src/tok.o build/src/parse.o'
+;
+; ONLY IF 'mocc' needs to be rebuilt:
+
+; to do the 'src/buf.c' target
+;  - run 'cc -c -o build/src/buf.c.o src/buf.c'
+; ONLY IF 'build/src/buf.c.o' needs to be rebuilt:
+;  - build/src/buf.c.o doesn't exist
+;  - build/src/buf.c.o exists, but src/buf.c has been modified since the last time we built build/src/buf.c.o
+;  - build/src/buf.c.o exists, and src/buf.c hasn't been modified, but build/src/buf.c.d exists and one of the files in it has been modified since the last time we built build/src/buf.c.o
+
+
+
+; Do I have to care about the relationship between 'src/buf.c' and 'build/src/buf.o'?  No
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+; a buildable represents a relation from /dependencies/ to /products/
+; a buildable will be built if any of its dependencies are dirty, or if it is dirty
+
+; a buildable is dirty if its current state is incompatible with a previously snapshotted state
+; or, if there is no previously snapshotted state--for instance, if this is the first time building the buildable
+
+(in-package :fancybuild)
+
+(defclass buildable ()
+  ((dependencies :initarg :dependencies :initform nil)
+   (cached-snapshot :initform nil)
+   (pretty-name :initarg :pretty-name :initform "")
+   (unique-key :initform nil)))
+
+(defgeneric snapshot (buildable))
+(defgeneric is-dirty (buildable old))
+(defgeneric do-build (buildable))
+
+(defun build (b)
+  (mapcar #'build (slot-value b 'dependencies))
+  (when (and (not (slot-value b 'cached-snapshot))
+             (slot-value b 'unique-key)
+             (gethash (slot-value b 'unique-key) *global-cache*))
+    (setf (slot-value b 'cached-snapshot) (gethash (slot-value b 'unique-key) *global-cache*)))
+
+  (unless (and (slot-value b 'cached-snapshot)
+               (not (is-dirty b (slot-value b 'cached-snapshot))))
+    (format t "Building ~a...~%" (slot-value b 'pretty-name))
+    (handler-case (do-build b)
+      (error ()
+             (format t "Error building ~a!~%" (slot-value b 'pretty-name))
+             (uiop:quit))))
+  (setf (slot-value b 'cached-snapshot) (snapshot b))
+  (when (slot-value b 'unique-key)
+    (setf (gethash (slot-value b 'unique-key) *global-cache*)
+          (slot-value b 'cached-snapshot)))
+  nil)

src/fb-entry.lisp

@@ -0,0 +1,22 @@
+(in-package :fancybuild)
+
+(defparameter *targets* (make-hash-table :test #'equal))
+(defparameter *global-cache* (make-hash-table :test #'equal))
+
+;  (let ((proc (uiop:launch-program "sleep 0.4")))
+;    (format t "process is ~a.  Aliveness is ~a.  Waiting for it...~%" proc (uiop:process-alive-p proc))
+;    (uiop:wait-process proc)
+;    (format t "process is done!~%exiting~%"))
+
+(defun main ()
+  (unless (probe-file "fancy.build")
+    (format t "Could not find build description file 'fancy.build'.~%")
+    (uiop:quit))
+  (load "fancy.build")
+  (let ((target (gethash (or (cadr sb-ext:*posix-argv*) "default") *targets*)))
+    (if target
+      (progn
+        (build target)
+        (read-line *standard-input*)
+        (build target))
+      (format t "I don't know what to do with that...~%"))))