new syntax for makefile.

SYNTAX

@@ -1,18 +1,18 @@
 MAKEFILE:
 =========
 
-<makefile> ::= '(' + "makefile" + <makerule-clause>* + ')'
+<makefile> ::= '(' + "makefile" + { <makerule-clause> | <common-clause> }* ')'
 
 <makerule-clause> ::= <file-clause> 
 		      | <all-clause>
-		      | <md5-clause> 
+                      | <md5-clause> 
 		      | <always-clause> 
-		      | <once-clause>
+	              | <once-clause>
-		      | <common-file-clause> 
+	              | <perms-clause>
-		      | <common-all-clause>
+	              | <md5-perms-clause>
-		      | <common-md5-clause> 
+	              | <paranoid-clause>
-		      | <common-always-clause> 
+
-		      | <common-once-clause>
+<common-clause> ::= '(' + "common" + <makerule-clause>* + ')'
 
 <file-clause> ::= '(' + <fille-clause-identifier>
 		      + <target-spec> 
@@ -29,6 +29,21 @@ MAKEFILE:
 	             + <prereq-spec> 
 		     + <action-spec> + ')'
 
+<perms-clause> ::= '(' + <perms-clause-identifier>
+                       + <target-spec> 
+	               + <prereq-spec> 
+		       + <action-spec> + ')'
+
+<md5-perms-clause> ::= '(' + <md5-perms-clause-identifier>
+                           + <target-spec> 
+	                   + <prereq-spec> 
+		           + <action-spec> + ')'
+
+<paranoid-clause> ::= '(' + <paranoid-clause-identifier>
+                          + <target-spec> 
+	                  + <prereq-spec> 
+		          + <action-spec> + ')'
+
 <always-clause> ::= '(' + <always-clause-identifier>
 		        + <target-spec> 
 	                + <prereq-spec> 
@@ -44,63 +59,18 @@ MAKEFILE:
                              | "is-out-of-date?"
 
 <all-clause-identifier> ::= "all" 
-                             | "file-all" 
-                             | "all-out-of-date?"
 
 <md5-clause-identifier> ::= "md5" 
-                            | "file-md5" 
+
-                            | "fp-changed?"
+<perms-clause-identifier> ::= "perms" 
+
+<md5-perms-clause-identifier> ::= "md5-perms" 
+
+<paranoid-clause-identifier> ::= "paranoid" 
 
 <always-clause-identifier> ::= "always" 
-                               | "file-always" 
-                               | "phony" 
-                               | "is-out-of-date!"
 
 <once-clause-identifier> ::= "once" 
-                             | "file-once"
-
-<common-file-clause> ::= '(' + <common-file-clause-identifier>
-		      	     + <common-target-spec> 
-	              	     + <common-prereq-spec> 
-		      	     + <action>+ + ')'
-
-<common-all-clause> ::= '(' + <common-all-clause-identifier>
-		      	    + <common-target-spec> 
-	              	    + <common-prereq-spec> 
-		      	    + <action>+ + ')'
-
-<common-md5-clause> ::= '(' + <common-md5-clause-identifier>
-                     	    + <common-target-spec> 
-	             	    + <common-prereq-spec> 
-		     	    + <action-spec> + ')'
-
-<common-always-clause> ::= '(' + <common-always-clause-identifier>
-		               + <common-target-spec> 
-	                       + <common-prereq-spec> 
-		               + <action-spec> + ')'
-
-<common-once-clause> ::= '(' + <common-once-clause-identifier>
-		      	     + <common-target-spec> 
-	              	     + <common-prereq-spec> 
-		      	     + <action-spec> + ')'
-
-<common-file-clause-identifier> ::= "common-file" 
-                                    | "common-makefile-rule" 
-                                    | "common-is-out-of-date?"
-
-<common-all-clause-identifier> ::= "common-all" 
-                             	   | "common-file-all" 
-                             	   | "common-all-out-of-date?"
-
-<common-md5-clause-identifier> ::= "common-md5" 
-                                   | "common-file-md5" 
-                                   | "common-fp-changed?"
-
-<common-always-clause-identifier> ::= "common-always" 
-                                      | "common-file-always" 
-
-<common-once-clause-identifier> ::= "common-once" 
-                                    | "common-file-once"
 
 <common-target-spec> ::= <target-descr> | <target> | <target-list>
 <target-descr> ::= <target-pattern> | <target-rx>

autovars.scm

@@ -20,6 +20,9 @@
 (define fluid-$?/ (make-preserved-thread-fluid (list)))
 (define fluid-/$? (make-preserved-thread-fluid (list)))
 
+(define (bind-all-fluids target prereqs prereqs-results thunk)
+  (bind-fluids-gnu target prereqs prereqs-results thunk))
+
 (define (bind-fluids-common target-name prefix match suffix thunk)
   (let (($* match)
 	($*= suffix)

common-rules.scm

@@ -1,157 +1,50 @@
-(define-record-type :common-rule
+(define-record-type :common-rules
-  (really-make-common-rule target prereqs wants-build? build-func)
+  (make-common-rules ls)
-  is-common-rule?
+  is-common-rules?
-  (target common-rule-target)
+  (ls common-rules-ls))
-  (prereqs common-rule-prereqs)
-  (wants-build? common-rule-wants-build?)
-  (build-func common-rule-build-func))
 
 (define (make-empty-common-rules) 
-  (let* ((target-pattern "%")
+  (make-common-rules (list match-all-func)))
-	 (make-does-file-exist? (lambda (target-name . cooked-prereqs)
-			      (lambda args 
-				(cons (file-not-exists? target-name) 
-				      (last args)))))
-	 (make-error-if-not-exists (lambda (target-name . cooked-prereqs)
-		       (lambda args
-			 (error "file (assumed leaf) does not exist:" 
-				target-name))))
-	 (common-rule (really-make-common-rule target-pattern
-					       (list) 
-					       make-does-file-exist?
-					       make-error-if-not-exists)))
-    (list common-rule)))
 
-(define (common-rules-add common-rules descr)
+(define (error-if-nonexistant target)
-  (let ((target (list-ref descr 0))
+  (error "file (assumed leaf) doesn't exist:" target))
-	(prereqs (list-ref descr 1))
+
-	(wants-build? (list-ref descr 2))
+(define (match-all-func default-target)
-	(build-func (list-ref descr 3)))
+  (list default-target 
-    (cons (really-make-common-rule target prereqs wants-build? build-func)
+	(list) 
-	  common-rules)))
+	(lambda args 
+	  (let ((target (car args))
+		(init-state (last args)))
+	    (cons (file-not-exists? default-target) init-state)))
+	(lambda args 
+	  (let ((target (car args))
+		(cooked-state (last args)))
+	    (error-if-nonexistant target)))))
+
+(define (add-common-rules common-rules func)
+  (make-common-rules (cons func (common-rules-ls common-rules))))
 
 (define (search-match-in-common-rules common-rules target)
-  (if (null? common-rules)
+  (let ((common-rs (common-rules-ls common-rules)))
-      #f
+    (if (null? common-rs)
-      (let next-common-rule ((current (car common-rules))
+	#f
-			     (todo (cdr common-rules)))
+	(let next-common-rule ((current (car common-rs))
-	(let ((maybe-target (is-matched-by? (common-rule-target current) target)))
+			       (todo (cdr common-rs)))
-	  (if maybe-target
+	  (let ((maybe-target (current target)))
-	      (let* ((prefix (list-ref maybe-target 0))
+	    (if maybe-target
-		     (match (list-ref maybe-target 1))
+		maybe-target
-		     (suffix (list-ref maybe-target 2))
+		(if (null? todo)
-		     (target-name (string-append prefix match suffix))
+		    #f
-		     (cooked-prereqs (map (lambda (prereq)
+		    (next-common-rule (car todo) (cdr todo)))))))))
-					    (if (string? prereq) 
-						(replace-by-match prereq match)
-						prereq))
-					  (common-rule-prereqs current)))
-		     (make-wants-build? (common-rule-wants-build? current))
- 		     (wants-build? 
-		      (lambda args 
-			(bind-fluids-common target-name prefix match suffix
-					    (lambda () 
-					      (apply
-					       (apply make-wants-build? 
-						      (append (list target-name) 
-							      cooked-prereqs))
-					       args)))))
-		     (make-build-func (common-rule-build-func current))
-		     (build-func 
-		      (lambda args
-			(bind-fluids-common target-name prefix match suffix 
-					    (lambda () 
-					      (apply 
-					       (make-build-func target-name 
-								cooked-prereqs)
-					       args))))))
-		(list target-name cooked-prereqs wants-build? build-func))
-	      (if (null? todo)
-		  #f
-		  (next-common-rule (car todo) (cdr todo))))))))
 
-(define (common-rcs->common-rules common-rules)
+(define (common-rcs->common-rules common-rcs)
-  (let ((empty-rules (make-empty-common-rules))
+  (let ((empty-rules (make-empty-common-rules)))
-	(common-rcs common-rules)) ; maybe reverse list
     (if (null? common-rcs)
 	empty-rules
-	(let each-rc ((rc (car common-rcs))
+	(let for-each-rc ((rc (car common-rcs))
-		      (todo (cdr common-rcs))
+			  (todo (cdr common-rcs))
-		      (done empty-rules))
+			  (done empty-rules))
-	  (if (null? todo)
+	  (let ((current (add-common-rules done rc)))
-	      (common-rules-add done rc)
+	    (if (null? todo)
-	      (each-rc (car todo) (cdr todo) (common-rules-add done rc)))))))
+		current
-
+		(for-each-rc (car todo) (cdr todo) current)))))))
-;;; 
-;;; returns a list containing three elements or false
-;;; the first element is the left part of the match
-;;; the second element is the middle part of the match
-;;; the third element is the right part of the match
-;;;
-;;; (is-matched-by? "%.o" "bar.o") ---> '("" "bar" ".o")
-;;; (is-matched-by? "%.tex" "bar.o") ---> #f
-;;; 
-(define (is-matched-by? target-descr target-name)
-  (let ((submatches (if (string? target-descr)
-			(get-submatches-percent target-descr)
-			#f)))
-    (if submatches 
-	(let* ((left (list-ref submatches 0))
-	       (middle (list-ref submatches 1))
-	       (right (list-ref submatches 2))
-	       (constructed-rx (if (and (string? middle) (string=? "%" middle))
-				   (rx (: (submatch (: bos ,left))
-					  (submatch (* any))
-					  (submatch (: ,right eos))))
-				   (rx (: (submatch (: bos ,left))
-					  (submatch ,middle)
-					  (submatch (: ,right eos))))))
-	       (maybe-match (regexp-search constructed-rx target-name)))
-	  (if maybe-match
-	      (map (lambda (match-no)
-		     (match:substring maybe-match match-no))
-		   (list 1 2 3))
-	      #f))
-	(let ((maybe-match (regexp-search target-descr target-name)))
-	  (if maybe-match
-	      (map (lambda (match-no) (match:substring maybe-match match-no))
-		   (list 1 2 3))
-	      #f)))))
-
-(define (get-submatches-percent target-descr)
-  (map (lambda (match-no)
-	 (match:substring (regexp-search (rx (: (submatch (: bos (* any)))
-						(submatch "%") 
-						(submatch (: (* any) eos))))
-					 target-descr)
-			  match-no))
-       (list 1 2 3)))
-
-;;; 
-;;; returns the string where the match is replaced with replacement
-;;; or the identity of maybe-match
-;;; 
-;;; (replace-by-match "no-percents.c" "foo") ---> "no-percents.c"
-;;; (replace-by-match "%.c" "foo") ---> "foo.c"
-;;; 
-(define (replace-by-match maybe-match replacement)
-  (regexp-substitute/global 
-   #f 
-   (rx (: (submatch (* any)) (submatch "%") (submatch (* any))))
-   maybe-match
-   'pre 1 replacement 3 'post))
-
-(define (common-rules-show common-rules)
-  (display "\n=== \n=== COMMON RULES") (newline)
-  (for-each (lambda (common-rule)
-	      (display "=== ") (newline)
-	      (let* ((target (common-rule-target common-rule))
-		     (prereqs (common-rule-prereqs common-rule))
-		     (wants-build? (common-rule-wants-build? common-rule))
-		     (build-func (common-rule-build-func common-rule)))
-		(display "=== target       : ") (display target) (newline)
-		(display "=== prereqs      : ") (display prereqs) (newline)
-		(display "=== wants-build? : ") (display wants-build?) (newline)
-		(display "=== build-func   : ") (display build-func) (newline)))
-	    common-rules)
-  (newline))

examples/makefile-common-rules.scm

@@ -4,33 +4,48 @@
 	"libwildio.so.1" "libmymath.so.1" 
 	"libwildio.so" "libmymath.so" 
 	"show-sqrt" 
-	"manual.dvi" "manual.pdf" "manual.log" "manual.aux"))
+	"manual.dvi" "manual.pdf" "manual.ps" "manual.log" "manual.aux"
+	"a-manual.dvi" "a-manual.pdf" "a-manual.ps" "a-manual.log" "a-manual.aux"
+	"b-manual.dvi" "b-manual.pdf" "b-manual.ps" "b-manual.log" "b-manual.aux"
+	"c-manual.dvi" "c-manual.pdf" "c-manual.ps" "c-manual.log" "c-manual.aux"
+	"d-manual.dvi" "d-manual.pdf" "d-manual.ps" "d-manual.log" "d-manual.aux"
+	"e-manual.dvi" "e-manual.pdf" "e-manual.ps" "e-manual.log" "e-manual.aux"
+	"f-manual.dvi" "f-manual.pdf" "f-manual.ps" "f-manual.log" "f-manual.aux"
+	"g-manual.dvi" "g-manual.pdf" "g-manual.ps" "g-manual.log" "g-manual.aux"
+	"h-manual.dvi" "h-manual.pdf" "h-manual.ps" "h-manual.log" "h-manual.aux"
+	"i-manual.dvi" "i-manual.pdf" "i-manual.ps" "i-manual.log" "i-manual.aux"
+	"j-manual.dvi" "j-manual.pdf" "j-manual.ps" "j-manual.log" "j-manual.aux"
+	"another-manual.dvi" "another-manual.pdf" "another-manual.ps" 
+	"another-manual.log" "another-manual.aux"))
 
+;(string-append ($*) ".c") (string-append ($*) ".h")
 (define file-set
   (makefile
-   (common-file "%.o"
+   (common-rx
-		("%.c" "%.h")
+    (file (rx (: (submatch "") (submatch (+ any)) (submatch ".o")))
-		(run (gcc -fPIC -c ,($<))))
+	  ("%.c" "%.h")
-   (common-file "lib%.so.1.0"
+	  (run (gcc -fPIC -c ,(string-append ($*) ".c")))))
-		("%.o")
+   (common-%
-		(run 
+    (file "lib%.so.1.0"
-		 (gcc -shared ,(string-append "-Wl,-soname," ($=*) ".so.1") 
+	  ("%.o")
-		      -o ,($@) ,($<))))
+	  (run 
-   (common-file "lib%.so.1" 
+	   (gcc -shared ,(string-append "-Wl,-soname," ($=*) ".so.1") 
-		("lib%.so.1.0") 
+		-o ,($@) ,($<))))
-		(create-symlink ($<) ($@)))
+    (file "lib%.so.1" 
-   (common-file "lib%.so" 
+	  ("lib%.so.1.0") 
-		("lib%.so.1") 
+	  (create-symlink ($<) ($@)))
-		(create-symlink ($<) ($@)))
+    (file "lib%.so" 
-   (common-file "%.dvi"
+	  ("lib%.so.1") 
-		("%.tex")
+	  (create-symlink ($<) ($@)))
-		(run (latex ,($<))))
+    (file "%.dvi"
-   (common-file "%.pdf"
+	  ("%.tex")
-		("%.dvi")
+	  (run (latex ,($<))))
-		(run (dvipdfm -o ,($@) ,($<))))
+    (file "%.pdf"
-   (common-file "%.ps"
+	  ("%.dvi")
-		("%.dvi")
+	  (run (dvipdfm -o ,($@) ,($<))))
-		(run (dvips -o ,($@) ,($<))))
+    (file "%.ps"
+	  ("%.dvi")
+	  (run (dvips -o ,($@) ,($<)))))
    ;; 
    ;; build the program
    ;;
@@ -42,7 +57,18 @@
    ;; fake install
    ;;
    (always "install"
-	   ("show-sqrt" "manual.ps" "manual.dvi" "manual.pdf")
+	   ("show-sqrt" "manual.ps" "manual.pdf" 
+	    "another-manual.pdf" "another-manual.ps"
+	    "a-manual.dvi" "a-manual.pdf" "a-manual.ps" 
+	    "b-manual.dvi" "b-manual.pdf" "b-manual.ps" 
+	    "c-manual.dvi" "c-manual.pdf" "c-manual.ps" 
+	    "d-manual.dvi" "d-manual.pdf" "d-manual.ps" 
+	    "e-manual.dvi" "e-manual.pdf" "e-manual.ps" 
+	    "f-manual.dvi" "f-manual.pdf" "f-manual.ps" 
+	    "g-manual.dvi" "g-manual.pdf" "g-manual.ps" 
+	    "h-manual.dvi" "h-manual.pdf" "h-manual.ps" 
+	    "i-manual.dvi" "i-manual.pdf" "i-manual.ps" 
+	    "j-manual.dvi" "j-manual.pdf" "j-manual.ps") 
 	   (for-each (lambda (f) (display ">>> ") (display f) (newline)) ($+))
 	   (display "install done.\n"))
    ;; 

macros.scm

@@ -1,376 +1,166 @@
-;;; 
-;;; MAKEFILE:
-;;; =========
-;;;
-;;; 
-;;; <makefile> ::= '(' + "makefile" + <makerule-clause>* + ')'
-;;; <makerule-clause> ::= <file-clause> 
-;;;                       | <all-clause> 
-;;;                       | <md5-clause> 
-;;; 		          | <always-clause> 
-;;; 		          | <once-clause>
-;;;                       | <common-file-clause> 
-;;;                       | <common-all-clause> 
-;;;                       | <common-md5-clause> 
-;;; 		          | <common-always-clause> 
-;;; 		          | <common-once-clause>
-;;; 
-;;;
 (define-syntax makefile
+  (syntax-rules (pred)
+    ((makefile ?clauses ...)
+     (let ((id=? string=?))
+       (clauses->lists id=? () () ?clauses ...)))
+    ((makefile (pred id=?) ?clauses ...)
+       (clauses->lists id=? () () ?clauses ...))))
+
+(define-syntax clauses->lists
+  (syntax-rules (common-% common-rx)
+    ((clauses->lists pred (?rc0 ...) (?func1 ...) (common-% ?%0 ...) ?clause1 ...)
+     (clauses->lists pred 
+		     (?rc0 ...) 
+		     (?func1 ... (common-%-clause->func pred ?%0) ...)
+		     ?clause1 ...))
+    ((clauses->lists pred (?rc0 ...) (?func1 ...) (common-rx ?rx0 ...) ?clause1 ...)
+     (clauses->lists pred 
+		     (?rc0 ...) 
+		     (?func1 ... (common-rx-clause->func pred ?rx0) ...)
+		     ?clause1 ...))
+    ((clauses->lists pred (?rc1 ...) (?func0 ...) ?clause0 ?clause1 ...)
+     (clauses->lists pred 
+		     (?rc1 ... (clause->rc pred ?clause0)) 
+		     (?func0 ...) 
+		     ?clause1 ...))
+    ((clauses->lists pred (?rc0 ...) (?func0 ...))
+      (rcs+commons->rules pred 
+			  (list ?rc0 ...) 
+			  (list ?func0 ...)))))
+
+(define-syntax common-rx-clause->func
   (syntax-rules () 
-    ((makefile ?rule0 ...) 
+    ((common-rx-clause->func pred 
-     (sort-rules () () ?rule0 ...))))
+			     (?out-of-date?-func ?target-rx 
+						 (?prereq-pattern0 ...) 
+						 ?action0 ...))
+     (lambda (maybe-target)
+       (let ((target-rx ?target-rx))
+	 (common-clause->func maybe-target
+			      target-rx 
+			      pred
+			      (?out-of-date?-func ?target-rx 
+						  (?prereq-pattern0 ...) 
+						  ?action0 ...)))))))
 
-;;; 
+(define-syntax common-%-clause->func
-;;; Each rule will be transformed into something similar to this:
-;;; 
-;;; (cons () 
-;;;       ("target" ("prereq0" ...) is-out-of-date? (lambda () ?action0 ...)))
-;;; 
-;;; or this
-;;; 
-;;; (cons ("target" ("prereq0" ...) is-out-of-date? (lambda () ?action0 ...) 
-;;;       ()))
-;;; 
-;;; The car of each result then goes into the file-rules-list while the
-;;; cdr goes into the common-rules-list. At the end those elements in each
-;;; of the file-rules-list and the common-rules-list being empty lists are
-;;; removed. The result are the cons-ed remaining lists.
-;;; 
-(define-syntax sort-rules
   (syntax-rules () 
-    ((sort-rules (?file0 ...) (?common0 ...))
+    ((common-%-clause->func pred
-     (let ((file-rules (remove null? (list ?file0 ...)))
+			    (?out-of-date?-func ?target-pattern 
-	   (common-rules (remove null? (list ?common0 ...))))
+						(?prereq-pattern0 ...) 
-       (cons file-rules common-rules)))
+						?action0 ...))
-    ((sort-rules (?file1 ...) (?common1 ...) ?rule0 ?rule1 ...)
+     (lambda (maybe-target)
-     (let ((rule-result ?rule0))
+       (let* ((pattern ?target-pattern)
-       (let ((common0 (cdr rule-result))
+	      (left (common-%-pattern->match pattern 1))
-	     (file0 (car rule-result)))
+	      (middle (common-%-pattern->match pattern 2))
-       (sort-rules (file0 ?file1 ...) (common0 ?common1 ...) ?rule1 ...))))))
+	      (right (common-%-pattern->match pattern 3))
+	      (target-rx (if (string=? "%" middle)
+			     (rx (: (submatch (: bos ,left))
+				    (submatch (* any))
+				    (submatch (: ,right eos))))
+			     (rx (: (submatch (: bos ,left))
+				    (submatch ,middle)
+				    (submatch (: ,right eos)))))))
+	 (common-clause->func maybe-target 
+			      target-rx 
+			      pred
+			      (?out-of-date?-func ?target-pattern
+						  (?prereq-pattern0 ...)
+						  ?action0 ...)))))))
 
-;;; 
+(define-syntax common-%-pattern->match
-;;; MAKERULE-CLAUSES:
+  (syntax-rules () 
-;;; =================
+    ((common-%-pattern->match ?target-pattern ?no)
-;;;
+     (match:substring (regexp-search (rx (: (submatch (: bos (* any)))
-;;; 
+					    (submatch "%") 
-;;; <file-clause>
+					    (submatch (: (* any) eos))))
-;;; 
+				     ?target-pattern)
-(define-syntax makefile-rule
+		      ?no))))
-  (syntax-rules ()
-    ((makefile-rule ?target ?prereqs ?action0 ...) 
-     (file ?target ?prereqs ?action0 ...))))
 
-(define-syntax is-out-of-date?
+(define-syntax common-s/%/match
-  (syntax-rules ()
+  (syntax-rules () 
-    ((is-out-of-date? ?target ?prereqs ?action0 ...) 
+    ((common-s/%/match ?pattern ?match)
-     (file ?target ?prereqs ?action0 ...))))
+     (regexp-substitute/global 
+      #f (rx (: (submatch (: bos (* any)))
+		(submatch "%") 
+		(submatch (: (* any) eos)))) ?pattern 'pre 1 ?match 3 'post))))
 
-(define-syntax file
+(define-syntax common-clause->func
-  (syntax-rules ()
+  (syntax-rules () 
-    ((file ?target (?prereq0 ...) ?action0 ...)
+    ((common-clause->func maybe-target 
-     (file-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
+			  target-rx 
+			  pred
+			  (?out-of-date?-func ?target-pattern 
+					      (?prereq-pattern0 ...) 
+					      ?action0 ...))
+     (let* ((match-data (regexp-search target-rx maybe-target))
+	    (maybe-target-matches (if match-data 
+				      (map (lambda (no)
+					     (match:substring match-data no))
+					   (list 1 2 3))
+				      #f)))
+       (if maybe-target-matches
+	   (let* ((left (list-ref maybe-target-matches 0))
+		  (target-match (list-ref maybe-target-matches 1))
+		  (right (list-ref maybe-target-matches 2))
+		  (target-name (string-append left target-match right))
+		  (prereqs (list ?prereq-pattern0 ...))
+		  (cooked-prereqs (map (lambda (prereq) 
+					 (if (string? prereq)
+					     (common-s/%/match prereq target-match)
+					     prereq))
+				       prereqs)))
+	     (list target-name
+		   cooked-prereqs
+		   ;;out-to-date?-func 
+		   (lambda args 
+		     (let ((init-state (last args)))
+		       (cons (bind-fluids-common 
+			      target-name left target-match right
+			      (lambda () 
+				(?out-of-date?-func target-name 
+						    cooked-prereqs)))
+			     init-state)))
+		   ;; build-func 
+		   (lambda args 
+		     (let ((cooked-state (last args))
+			   (prereqs-results (cdr (reverse (cdr args)))))
+		       (cons (bind-fluids-common 
+			      target-name left target-match right
+			      (lambda () 
+				(bind-all-fluids target-name 
+						 cooked-prereqs 
+						 prereqs-results 
+						 (lambda () ?action0 ...))))
+			     cooked-state)))))
+	   #f)))))
 
-(define-syntax file-tmpvars
+(define-syntax clause->rc
   (syntax-rules ()
-    ((file-tmpvars (tmp1 ...) ?target () ?action0 ...)
+    ((clause->rc pred (?func ?target (?prereq0 ...) ?action0 ...))
+     (clause->rc-tmp () pred (?func ?target (?prereq0 ...) ?action0 ...)))))
+
+(define-syntax clause->rc-tmp
+  (syntax-rules ()
+    ((clause->rc-tmp (tmp1 ...) pred (?func ?target () ?action0 ...))
      (let ((target ?target)
-	   (prereqs (list tmp1 ...))
+	   (prereqs (list tmp1 ...)))
-	   (thunk (lambda () ?action0 ...)))
+       (list target 
-       (cons (list target
+	     prereqs 
-		   prereqs
+	     (lambda args 
-		   (make-is-out-of-date? target tmp1 ...)
+	       (let ((init-state (last args)))
-		   (make-file-build-func target prereqs thunk))
+		 (cons (?func target (list tmp1 ...))
-	     (list))))
+		       init-state)))
-    ((file-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) 
+	     (lambda args 
-		   ?action0 ...)
+	       (let ((cooked-state (last args))
+		     (results (cdr (reverse (cdr args)))))
+		 (cons (bind-all-fluids target prereqs results 
+					(lambda () ?action0 ...))
+		       cooked-state))))))
+    ((clause->rc-tmp (tmp1 ...) 
+		     pred 
+		     (?func ?target (?prereq0 ?prereq1 ...) ?action0 ...))
      (let ((tmp2 ?prereq0))
-       (file-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) 
+       (clause->rc-tmp (tmp1 ... tmp2) 
-		     ?action0 ...)))))
+		       pred 
-
+		       (?func ?target (?prereq1 ...) ?action0 ...))))))
-;;; 
-;;; <all-clause>
-;;; 
-(define-syntax all
-  (syntax-rules ()
-    ((makefile-rule ?target ?prereqs ?action0 ...) 
-     (file-all ?target ?prereqs ?action0 ...))))
-
-(define-syntax all-out-of-date?
-  (syntax-rules ()
-    ((all-out-of-date? ?target ?prereqs ?action0 ...) 
-     (file-all ?target ?prereqs ?action0 ...))))
-
-(define-syntax file-all
-  (syntax-rules ()
-    ((file-all ?target (?prereq0 ...) ?action0 ...)
-     (file-all-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
-
-(define-syntax file-all-tmpvars
-  (syntax-rules ()
-    ((file-all-tmpvars (tmp1 ...) ?target () ?action0 ...)
-     (let ((target ?target)
-	   (prereqs (list tmp1 ...))
-	   (thunk (lambda () ?action0 ...)))
-       (cons (list target
-		   prereqs
-		   (make-all-out-of-date? target tmp1 ...)
-		   (make-all-build-func target prereqs thunk))
-	     (list))))
-    ((file-all-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) 
-		       ?action0 ...)
-     (let ((tmp2 ?prereq0))
-       (file-all-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) 
-			 ?action0 ...)))))
-
-;;; 
-;;; <md5-clause>
-;;; 
-(define-syntax md5
-  (syntax-rules ()
-    ((md5 ?target ?prereqs ?action0 ...) 
-     (file-md5 ?target ?prereqs ?action0 ...))))
-
-(define-syntax file-md5
-  (syntax-rules ()
-    ((file-md5 ?target (?prereq0 ...) ?action0 ...) 
-     (file-md5-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
-
-(define-syntax file-md5-tmpvars
-  (syntax-rules ()
-    ((file-md5-tmpvars (tmp1 ...) ?target () ?action0 ...)
-     (let ((target ?target)
-	   (prereqs (list tmp1 ...))
-	   (thunk (lambda () ?action0 ...)))
-       (cons (list target
-		   prereqs
-		   (make-md5-sum-changed? target tmp1 ...)
-		   (make-md5-build-func target prereqs thunk))
-	     (list))))
-    ((file-md5-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) 
-		       ?action0 ...)
-     (let ((tmp2 ?prereq0))
-       (file-md5-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) 
-			 ?action0 ...)))))
-
-;;; 
-;;; <always-clause>
-;;; 
-(define-syntax phony
-  (syntax-rules ()
-    ((phony ?target ?prereqs ?action0 ...) 
-     (file-always ?target ?prereqs ?action0 ...))))
-
-(define-syntax always
-  (syntax-rules ()
-    ((always ?target ?prereqs ?action0 ...) 
-     (file-always ?target ?prereqs ?action0 ...))))
-
-(define-syntax is-out-of-date!
-  (syntax-rules ()
-    ((is-out-of-date! ?target ?prereqs ?action0 ...) 
-     (file-always ?target ?prereqs ?action0 ...))))
-
-(define-syntax file-always
-  (syntax-rules ()
-    ((file-always ?target ?prereqs ?action0 ...)
-     (file-always-tmpvars () ?target ?prereqs ?action0 ...))))
-
-(define-syntax file-always-tmpvars
-  (syntax-rules ()
-    ((file-always-tmpvars (tmp1 ...) ?target () ?action0 ...)
-     (let ((target ?target)
-	   (prereqs (list tmp1 ...))
-	   (thunk (lambda () ?action0 ...)))
-       (cons (list target
-		   prereqs
-		   (make-is-out-of-date! target tmp1 ...)
-		   (make-always-build-func target prereqs thunk))
-	     (list))))
-    ((file-always-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) 
-			  ?action0 ...)
-     (let ((tmp2 ?prereq0))
-       (file-always-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) 
-			    ?action0 ...)))))
-
-;;; 
-;;; <once-clause>
-;;; 
-(define-syntax once
-  (syntax-rules ()
-    ((once ?target ?prereqs ?action0 ...)
-     (file-once ?target ?prereqs ?action0 ...))))
-
-(define-syntax file-once
-  (syntax-rules ()
-    ((file-once ?target (?prereq0 ...) ?action0 ...)
-     (file-once-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
-
-(define-syntax file-once-tmpvars
-  (syntax-rules ()
-    ((file-once-tmpvars (tmp1 ...) ?target () ?action0 ...)
-     (let ((target ?target)
-	   (prereqs (list tmp1 ...))
-	   (thunk (lambda () ?action0 ...)))
-       (cons (list target
-		   prereqs
-		   (make-once target tmp1 ...)
-		   (make-once-build-func target prereqs thunk))
-	     (list))))
-    ((file-once-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) 
-			?action0 ...)
-     (let ((tmp2 ?prereq0))
-       (file-once-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) 
-			  ?action0 ...)))))
-
-;;; COMMON-MAKERULE-CLAUSES:
-;;; ========================
-;;;
-;;; 
-;;; 
-;;; <common-file-clause>
-;;; 
-(define-syntax common-file
-  (syntax-rules ()
-    ((common-file ?target (?prereq0 ...) ?action0 ...)
-     (common-file-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
-
-(define-syntax common-file-tmpvars
-  (syntax-rules ()
-    ((common-file-tmpvars (tmp1 ...) ?target () ?action0 ...)
-     (let ((target ?target)
-	   (prereqs (list tmp1 ...))
-	   (thunk (lambda () ?action0 ...)))
-       (cons (list) 
-	     (list target 
-		   prereqs 
-		   (make-common-is-out-of-date? target tmp1 ...)
-		   (make-common-file-build-func target prereqs thunk)))))
-    ((common-file-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) 
-			  ?action0 ...)
-     (let ((tmp2 ?prereq0))
-       (common-file-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) 
-			    ?action0 ...)))))
-
-;;; 
-;;; <common-all-clause>
-;;; 
-;;; to achieve consistency only file will use the file-tmpvars 
-;;; macro directly and all other macros use this clause
-;;; 
-(define-syntax common-all
-  (syntax-rules ()
-    ((common-all ?target ?prereqs ?action0 ...) 
-     (common-file-all ?target ?prereqs ?action0 ...))))
-
-(define-syntax common-file-all
-  (syntax-rules ()
-    ((common-file-all ?target (?prereq0 ...) ?action0 ...)
-     (common-file-all-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
-
-(define-syntax common-file-all-tmpvars
-  (syntax-rules ()
-    ((common-file-all-tmpvars (tmp1 ...) ?target () ?action0 ...)
-     (let ((target ?target)
-	   (prereqs (list tmp1 ...))
-	   (thunk (lambda () ?action0 ...)))
-       (cons (list) 
-	     (list target
-		   prereqs
-		   (make-common-all-out-of-date? target tmp1 ...)
-		   (make-common-all-build-func target prereqs thunk)))))
-    ((common-file-all-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) 
-			    ?action0 ...)
-     (let ((tmp2 ?prereq0))
-       (common-file-all-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) 
-			      ?action0 ...)))))
-
-;;; 
-;;; <common-md5-clause>
-;;; 
-(define-syntax common-md5
-  (syntax-rules ()
-    ((common-md5 ?target ?prereqs ?action0 ...) 
-     (common-file-md5 ?target ?prereqs ?action0 ...))))
-
-(define-syntax common-file-md5
-  (syntax-rules ()
-    ((common-file-md5 ?target (?prereq0 ...) ?action0 ...) 
-     (common-file-md5-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
-
-(define-syntax common-file-md5-tmpvars
-  (syntax-rules ()
-    ((common-file-md5-tmpvars (tmp1 ...) ?target () ?action0 ...)
-     (let ((target ?target)
-	   (prereqs (list tmp1 ...))
-	   (thunk (lambda () ?action0 ...)))
-       (cons (list) 
-	     (list target
-		   prereqs
-		   (make-common-md5-sum-changed? target tmp1 ...)
-		   (make-common-md5-build-func target prereqs thunk)))))
-    ((common-file-md5-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) 
-			    ?action0 ...)
-     (let ((tmp2 ?prereq0))
-       (common-file-md5-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) 
-			      ?action0 ...)))))
-
-;;; 
-;;; <common-always-clause>
-;;; 
-(define-syntax common-always
-  (syntax-rules ()
-    ((common-always ?target ?prereqs ?action0 ...) 
-     (common-file-always ?target ?prereqs ?action0 ...))))
-
-(define-syntax common-file-always
-  (syntax-rules ()
-    ((common-file-always ?target ?prereqs ?action0 ...)
-     (common-file-always-tmpvars () ?target ?prereqs ?action0 ...))))
-
-(define-syntax common-file-always-tmpvars
-  (syntax-rules ()
-    ((common-file-always-tmpvars (tmp1 ...) ?target () ?action0 ...)
-     (let ((target ?target)
-	   (prereqs (list tmp1 ...))
-	   (thunk (lambda () ?action0 ...)))
-       (cons (list) 
-	     (list target
-		   prereqs
-		   (make-common-is-out-of-date! target tmp1 ...)
-		   (make-common-always-build-func target prereqs thunk)))))
-    ((common-file-always-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) 
-			       ?action0 ...)
-     (let ((tmp2 ?prereq0))
-       (common-file-always-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) 
-				 ?action0 ...)))))
-
-;;; 
-;;; <common-once-clause>
-;;; 
-(define-syntax common-once
-  (syntax-rules ()
-    ((common-once ?target ?prereqs ?action0 ...)
-     (common-file-once ?target ?prereqs ?action0 ...))))
-
-(define-syntax common-file-once
-  (syntax-rules ()
-    ((common-file-once ?target (?prereq0 ...) ?action0 ...)
-     (common-file-once-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
-
-(define-syntax common-file-once-tmpvars
-  (syntax-rules ()
-    ((common-file-once-tmpvars (tmp1 ...) ?target () ?action0 ...)
-     (let ((target ?target)
-	   (prereqs (list tmp1 ...))
-	   (thunk (lambda () ?action0 ...)))
-       (cons (list) 
-	     (list target
-		   prereqs
-		   (make-common-once target tmp1 ...)
-		   (make-common-once-build-func target prereqs thunk)))))
-    ((common-file-once-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) 
-			     ?action0 ...)
-     (let ((tmp2 ?prereq0))
-       (common-file-once-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) 
-			       ?action0 ...)))))

make.scm

@@ -1,10 +1,9 @@
-(define (make rcs targets . maybe-arg)
+(define (make rules targets . maybe-args)
-  (let-optionals maybe-arg ((init-state (list)))
+  (let-optionals maybe-args ((pred string=?)
-    (let* ((common-rule-candidates (cdr rcs))
+			     (init-state (list)))
-	   (rule-candidates (car rcs))
+    (let* ((rule-set (rules->rule-set rules))
-	   (rules (rcs->rules rule-candidates common-rule-candidates))
+	   (target-rules (map (lambda (target) 
-	   (rule-set (rules->rule-set rules))
+				(lookup-rule pred target rules)) 
-	   (target-rules (map (lambda (t) (lookup-rule t rules))
 			      targets)))
       (map (lambda (t) 
 	     (rule-make t init-state rule-set))

packages.scm

@@ -128,8 +128,8 @@
   (open scheme-with-scsh
 	finite-types
 	srfi-9
-	big-util ; for breakpoints
+;	big-util ; for breakpoints
-	let-opt ; for logging
+;	let-opt ; for logging
 	threads
 	threads-internal
 	(with-prefix rendezvous cml-rv/)
@@ -139,6 +139,7 @@
 
 (define-interface make-rule-interface
   (export make-rule
+;	  set!-target/rule-alist
 	  is-rule?
 	  make-empty-rule-set
 	  rule-set-add
@@ -155,7 +156,7 @@
 	with-lock
 	threads
 	threads-internal
-	big-util ; for breakpoints
+;	big-util ; for breakpoints
 	srfi-1
 	srfi-9
 	finite-types
@@ -174,24 +175,7 @@
   (files make-rule-no-cml))
 
 (define-interface macros-interface
-  (export (makefile :syntax)
+  (export (makefile :syntax)))
-	  (file :syntax)
-	  (makefile-rule :syntax)
-	  (is-out-of-date? :syntax)
-	  (md5 :syntax)
-	  (file-md5 :syntax)
-	  (phony :syntax)
-	  (always :syntax)
-	  (is-out-of-date! :syntax)
-	  (once :syntax)
-	  (file-once :syntax)
-	  (common-file :syntax)
-	  (common-md5 :syntax)
-	  (common-file-md5 :syntax)
-	  (common-always :syntax)
-	  (common-file-always :syntax)
-	  (common-once :syntax)
-	  (common-file-once :syntax)))
 
 (define-structure macros macros-interface
   (open scheme-with-scsh
@@ -209,7 +193,7 @@
 	  lookup-rule
 	  rcs->dag
 	  dag->rcs
-	  rcs->rules
+	  rcs+commons->rules
 	  rules->rule-set))
 
 (define-structure to-rule-set to-rule-set-interface
@@ -239,35 +223,28 @@
   (files dfs))
 
 (define-interface templates-interface
-  (export make-file-build-func
+  (export all
-	  make-md5-build-func
+	  file
-	  make-always-build-func
+	  md5
-	  make-once-build-func
+	  always
-	  make-is-out-of-date!
+	  perms
-	  make-once
+	  md5-perms
-	  make-is-out-of-date?
+	  paranoid
-	  make-md5-sum-changed?
+	  once))
-          make-common-file-build-func
-	  make-common-md5-build-func
-	  make-common-always-build-func
-	  make-common-once-build-func
-	  make-common-is-out-of-date!
-	  make-common-once
-	  make-common-is-out-of-date?
-	  make-common-md5-sum-changed?))
 
 (define-structure templates templates-interface
   (open scheme-with-scsh
 	common-rules
 	autovars
 	srfi-1
-	big-util
+;	big-util
 	srfi-13)
   (files templates))
 
 (define-interface autovars-interface
   (export bind-fluids-common
 	  bind-fluids-gnu
+	  bind-all-fluids
 	  fluid-$@  
 	  fluid-$<  
 	  fluid-$?  
@@ -322,19 +299,16 @@
 
 (define-interface common-rules-interface
   (export make-empty-common-rules
-	  common-rules-add
+	  add-common-rules
-	  common-rules-show
 	  search-match-in-common-rules
-	  common-rcs->common-rules
+	  common-rcs->common-rules))
-	  is-matched-by?
-	  replace-by-match))
 
 (define-structure common-rules common-rules-interface
   (open scheme-with-scsh
 	autovars
 	srfi-1
 	srfi-9
-	big-util
+;	big-util
 	srfi-13)
   (files common-rules))
 

templates.scm

@@ -1,122 +1,45 @@
 (define digest-extensions (list ".md5" ".fp" ".digest"))
 
-(define (make-file-build-func target prereqs thunk)
+(define (same-mtime? target prereqs)
-  (lambda args 
+  (if (file-not-exists? target)
-;    (breakpoint "make-file-build-func")
+      #t
-    (let ((cooked-state (last args))
+      (if (null? prereqs)
-	  (prereqs-results (cdr (reverse (cdr args)))))
+	  #f
-      (cons (begin 
+	  (let ((target-mtime (file-last-mod target)))
-	      (display ";;; file      : ")
+	    (let for-each-prereq ((prereq (car prereqs))
-	      (display target)
+				  (todo (cdr prereqs)))
-	      (newline)
+	      (cond
-	      (bind-fluids-gnu target prereqs prereqs-results thunk))
+	       ((file-not-exists? prereq) 
-	    cooked-state))))
+		(error "nonexistent prerequisite" prereq))
+	       ((> (file-last-mod prereq) target-mtime) #t)
+	       ((null? todo) #f)
+	       (else (for-each-prereq (car todo) (cdr todo)))))))))
 
-(define (make-all-build-func target prereqs thunk)
+(define (all-same-mtime? target prereqs)
-  (lambda args 
+  (if (file-not-exists? target)
-;    (breakpoint "make-file-build-func")
+      #t
-    (let ((cooked-state (last args))
+      (if (null? prereqs)
-	  (prereqs-results (cdr (reverse (cdr args)))))
+	  #f
-      (cons (begin 
+	  (let ((target-mtime (file-last-mod target)))
-	      (display ";;; all       : ")
+	    (let for-each-prereq ((prereq (car prereqs))
-	      (display target)
+				  (todo (cdr prereqs)))
-	      (newline)
+	      (cond
-	      (bind-fluids-gnu target prereqs prereqs-results thunk))
+	       ((file-not-exists? prereq) 
-	    cooked-state))))
+		(error "nonexistent prerequisite" prereq))
+	       ((and (null? todo)
+		     (> (file-last-mod prereq) target-mtime)) #t)
+	       (else (and (> (file-last-mod prereq) target-mtime)
+			  (for-each-prereq (car todo) (cdr todo))))))))))
 
-(define (make-md5-build-func target prereqs thunk)
+(define (same-perms? target prereqs)
-  (lambda args 
+  (if (file-not-exists? target)
-;    (breakpoint "make-md5-build-func")
+      #t
-    (let ((cooked-state (last args))
+      (if (null? prereqs)
-	  (prereqs-results (cdr (reverse (cdr args)))))
+	  (error "no prerequisite in perms clause")
-      (cons (begin 
+	  (cond
-	      (display ";;; md5       : ")
+	   ((file-not-exists? (car prereqs))
-	      (display target)
+	    (error "nonexistent prerequisite" (car prereqs)))
-	      (newline)
+	   (else (= (file-mode target) (file-mode (car prereqs))))))))
-	      (bind-fluids-gnu target prereqs prereqs-results thunk))
-	    cooked-state))))
-
-(define (make-always-build-func target prereqs thunk)
-  (lambda args 
-;    (breakpoint "make-always-build-func")
-    (let ((cooked-state (last args))
-	  (prereqs-results (cdr (reverse (cdr args)))))
-      (cons (begin 
-	      (display ";;; always    : ")
-	      (display target)
-	      (newline)
-	      (bind-fluids-gnu target prereqs prereqs-results thunk))
-	    cooked-state))))
-
-(define (make-once-build-func target prereqs thunk)
-  (lambda args 
-;    (breakpoint "make-once-build-func")
-    (let ((cooked-state (last args))
-	  (prereqs-results (cdr (reverse (cdr args)))))
-      (cons (begin 
-	      (display ";;; once      : ")
-	      (display target)
-	      (newline)
-	      (bind-fluids-gnu target prereqs prereqs-results thunk))
-	    cooked-state))))
-
-(define (make-is-out-of-date! target . prereqs)
-  (lambda args 
-;    (breakpoint "make-is-out-of-date!")
-    (let ((init-state (last args)))
-      (cons #t init-state))))
-
-(define (make-once target . prereqs)
-  (lambda args
-;    (breakpoint "make-once")
-    (let ((init-state (last args)))
-      (cons (file-not-exists? target) init-state))))
-
-(define (make-is-out-of-date? target . prereqs)
- (lambda args 
-;    (breakpoint "make-is-out-of-date?")
-    (let ((init-state (last args)))
-      (cons (if (file-not-exists? target)
-		#t
-		(if (null? prereqs)
-		    #f
-		    (let ((target-mtime (file-last-mod target)))
-		      (let for-each-prereq ((prereq (car prereqs))
-					    (todo (cdr prereqs)))
-			(cond
-			 ((file-not-exists? prereq) 
-			  (error "nonexistent prerequisite" prereq))
-			 ((> (file-last-mod prereq) target-mtime) #t)
-			 ((null? todo) #f)
-			 (else (for-each-prereq (car todo) (cdr todo))))))))
-	    init-state))))
-
-(define (make-all-out-of-date? target . prereqs)
- (lambda args 
-;    (breakpoint "make-is-out-of-date?")
-    (let ((init-state (last args)))
-      (cons (if (file-not-exists? target)
-		#t
-		(if (null? prereqs)
-		    #f
-		    (let ((target-mtime (file-last-mod target)))
-		      (let for-each-prereq ((prereq (car prereqs))
-					    (todo (cdr prereqs)))
-			(cond
-			 ((file-not-exists? prereq) 
-			  (error "nonexistent prerequisite" prereq))
-			 ((and (null? todo)
-			       (> (file-last-mod prereq) target-mtime)) #t)
-			 (else (and (> (file-last-mod prereq) target-mtime)
-				    (for-each-prereq (car todo) (cdr todo)))))))))
-	    init-state))))
-
-(define (make-md5-sum-changed? target . prereqs)
-  (lambda args 
-;    (breakpoint "make-md5-sum-changed?")
-    (let ((init-state (last args)))
-      (cons (not (same-checksum? target digest-extensions prereqs))
-	    init-state))))
 
 (define (checksum-from-file basename extension)
   (let* ((bname (string-append basename extension))
@@ -193,37 +116,28 @@
 		   (else (error "no match in same-checksum?"))))))
 	   (else (error "no match in same-checksum?")))))))
 
-(define (make-common-is-out-of-date? target-descr . prereqs)
+(define (always target prereqs) #t)
-  (lambda args (apply make-is-out-of-date? args)))
 
-(define (make-common-file-build-func target-descr prereqs thunk)
+(define (once target prereqs)
-  (lambda (target-name cooked-prereqs)
+  (file-not-exists? target))
-    (make-file-build-func target-name cooked-prereqs thunk)))
 
-(define (make-common-all-out-of-date? target-descr . prereqs)
+(define (file target prereqs)
-  (lambda args (apply make-all-out-of-date? args)))
+  (same-mtime? target prereqs))
 
-(define (make-common-all-build-func target-descr prereqs thunk)
+(define (all target prereqs)
-  (lambda (target-name cooked-prereqs)
+  (all-same-mtime? target prereqs))
-    (make-all-build-func target-name cooked-prereqs thunk)))
 
-(define (make-common-md5-sum-changed? target-descr . prereqs)
+(define (md5 target prereqs)
-  (lambda args (apply make-md5-sum-changed? args)))
+  (not (same-checksum? target digest-extensions prereqs)))
 
-(define (make-common-md5-build-func target-descr prereqs thunk)
+(define (perms target prereqs)
-  (lambda (target-name cooked-prereqs)
+  (not (same-perms? target prereqs)))
-    (make-md5-build-func target-name cooked-prereqs thunk)))
 
-(define (make-common-is-out-of-date! target-descr . prereqs)
+(define (md5-perms target prereqs)
-  (lambda args (apply make-is-out-of-date! args)))
+  (and (not (same-checksum? target digest-extensions prereqs))
+       (not (same-perms? target prereqs))
+       (not (same-mtime? target prereqs))))
 
-(define (make-common-always-build-func target-descr prereqs thunk)
+(define (paranoid target prereqs)
-  (lambda (target-name cooked-prereqs)
+  (not (same-checksum? target digest-extensions prereqs)))
-    (make-always-build-func target-name cooked-prereqs thunk)))
 
-(define (make-common-once target-descr . prereqs)
-  (lambda args (apply make-once args)))
-
-(define (make-common-once-build-func target-descr prereqs thunk)
-  (lambda (target-name cooked-prereqs)
-    (make-once-build-func target-name cooked-prereqs thunk)))

to-rule-set.scm

@@ -14,11 +14,6 @@
 	   (make-dfs target prereqs (list wants-build? build-func))))
        rcs))
 
-;;; 
-;;; if dfs inserted leafs they have the ignored-data set to #f
-;;; the build-func will then be set to produce an error
-;;; in case of the file doesn't exist
-;;;
 (define (dag->rcs dag)
   (map (lambda (node)
 	 (let* ((ls (dfs->list node))
@@ -39,27 +34,27 @@
     (if maybe-rc maybe-rc (error "lookup-rc: rc not found."))))
 
 (define (lookup-fname fname rcs)
-  (let ((maybe-fname (find (lambda (current) 
+  (let ((maybe-fname (find (lambda (current)
-			     (eq? fname (car current))) 
+			     (eq? fname (car current)))
 			   rcs)))
     (if maybe-fname maybe-fname (error "lookup-fname: fname not found."))))
 
-(define (lookup-rule fname rules)
+(define (lookup-rule pred fname rules)
-  (let ((maybe-rule (assoc fname rules)))
+  (let ((maybe-rule (find (lambda (current) 
+			    (pred fname (car current)))
+			  rules)))
     (if maybe-rule 
 	(cdr maybe-rule) 
 	(error "lookup-rule: fname not found in rules."))))
 
-(define (rcs->rules rule-candidates common-rcs)
+(define (rcs+commons->rules pred rule-candidates common-rcs)
   (let* ((common-rules (common-rcs->common-rules common-rcs))
 	 (create-leaf (lambda (maybe-target)
 			(rc->dfs-node 
 			 (search-match-in-common-rules common-rules
 						       maybe-target))))
-	 (sorted-dag (dfs (rcs->dag rule-candidates) string=? #t create-leaf))
+	 (sorted-dag (dfs (rcs->dag rule-candidates) pred #t create-leaf))
 	 (sorted-rcs (dag->rcs sorted-dag)))
-    ;;(common-rules-show common-rules) (newline)
-    ;;(dfs-dag-show sorted-dag (car sorted-dag))
     (if (not (null? sorted-rcs))
 	(let for-all-rcs ((rc (car sorted-rcs))
 			  (todo (cdr sorted-rcs))
@@ -69,15 +64,18 @@
 		 (wants-build? (list-ref rc 2))
 		 (build-func (list-ref rc 3))
 		 (done (cons (cons target 
-				   (make-rule (map (lambda (p)
+				   (make-rule (map (lambda (prereq)
-						     (lookup-rule p last-done))
+						     (lookup-rule pred 
+								  prereq 
+								  last-done))
 						   prereqs)
 					      wants-build? 
 					      build-func))
 			     last-done)))
-	    (if (not (null? todo))
+	    (if (null? todo)
-		(for-all-rcs (car todo) (cdr todo) done)
+		done
-		done))))))
+		(for-all-rcs (car todo) (cdr todo) done))))
+	sorted-rcs)))
 
 (define (rules->rule-set rule-alist)
   (if (not (null? rule-alist))
@@ -91,37 +89,3 @@
 			       (cdr rules-to-do)
 			       next-rule-set)
 		next-rule-set))))))
-
-(define (rcs-show rcs)
-    (newline) (newline) (newline) (newline)
-    (display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
-    (display ";;;                       rcs-show                       ;;;\n")
-    (display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
-    (let ((rc-show (lambda (rc)
-		     (let ((target (list-ref rc 0))
-			   (prereqs (list-ref rc 1))
-			   (wants-build? (list-ref rc 2))
-			   (build-func (list-ref rc 3)))
-		       (newline)
-		       (display "; target:             ")
-		       (display target)
-		       (newline)
-		       (display "; prereqs:            ")
-		       (display prereqs)
-		       (newline)
-		       (display "; wants-build?:       ")
-		       (display wants-build?)
-		       (newline)
-		       (display "; build-func:         ")
-		       (display build-func)
-		       (newline)))))
-      (if (not (null? rcs))
-	  (let visit-each-rc ((current-rc (car rcs))
-			      (todo-rcs (cdr rcs)))
-	    (rc-show current-rc)
-	    (if (not (null? todo-rcs))
-		(visit-each-rc (car todo-rcs) (cdr todo-rcs))
-		(begin 
-		  (display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
-		  (display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
-		  (newline) (newline) (newline) (newline)))))))