*** empty log message ***

macros.scm

@@ -0,0 +1,106 @@
+(define-syntax make
+  (syntax-rules () 
+    ((make ?rule-trans-set (?target-fname0 ...) ?init-state)
+     (begin 
+       (let ((?target-rule (rule-candidate-get ?rule-trans-set ?target-fname0)))
+	 (if (not (null? (rule-trans-set-rule-candidates ?rule-trans-set)))
+	     (display "warning: rule-candidates not empty!\n"))
+	 (if (?target-rule)
+	     (rule-make ?target-rule
+			init-state
+			(rule-trans-set-rule-set ?rule-trans-set))
+	     (error "target-rule not found in rule-set.")))
+       ...))))
+
+(define-syntax makefile
+  (syntax-rules () 
+    ((makefile ?rule0 ...)
+     (let ((rule-trans-set (make-empty-rule-trans-set)))
+       ((?rule0) rule-trans-set) ...))))
+
+(define-syntax make-is-out-of-date? 
+  (syntax-rules () 
+    ((make-is-out-of-date? ?target)
+     (lambda ?args
+       (cons (file-not-exists? ?target) ?args)))
+    ((make-is-out-of-date? ?target ?prereq0 ...)
+     (lambda ?args
+       (cons (or (file-not-exists? ?target)
+		 (> (file-last-mod ?prereq0)
+		    (file-last-mod ?target))
+		 ...)
+	     (last ?args))))))
+
+(define-syntax make-is-out-of-date!
+  (syntax-rules () 
+    ((make-is-out-of-date? ?target ?prereq0 ...)
+     (lambda ?args
+       (cons #t (last ?args))))))
+
+(define-syntax make-has-md5-digest=?
+  (syntax-rules () 
+    ((make-has-md5-digest=? ?fingerprint ?target)
+     (lambda ?args
+       (cons (or (file-not-exists? ?target)
+		 (=? (md5-digest-for-port (open-input-file ?target))
+		     ?fingerprint))
+	     ?args)))
+    ((make-has-md5-digest=? ?fingerprint ?target ?prereq0 ...)
+     (lambda ?args
+       (cons (or (file-not-exists? ?target)
+		 (=? (md5-digest->number (md5-digest-for-port 
+					  (open-input-file ?target)))
+		     (md5-digest->number ?fingerprint)))
+	     (last ?args))))))
+
+(define-syntax makefile-rule
+  (syntax-rules ()
+    ((makefile-rule ?target (?prereq0 ...) ?thunk)
+     (makefile-rule-tmpvars () ?target (?prereq0 ...) ?thunk))))
+
+(define-syntax makefile-rule-tmpvars
+  (syntax-rules ()
+    ((makefile-rule-tmpvars (tmp1 ...) ?target () ?thunk)
+     ;; 
+     ;; ?target could be an expr: eval only once
+     ;; 
+     (let ((target ?target))
+       (lambda (rule-trans-set)
+	 (rule-trans-set-add! rule-trans-set
+			      target
+			      (list tmp1 ...)
+			      (make-is-out-of-date? target tmp1 ...)
+			      (lambda ?args (?thunk))))))
+    ;;
+    ;; recursively construct temporary, hygienic variables
+    ;;
+    ((makefile-rule-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk)
+     (let ((tmp2 ?prereq0))
+       (makefile-rule-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk)))))
+
+(define-syntax makefile-rule-md5
+  (syntax-rules ()
+    ((makefile-rule-md5 ?fingerprint ?target (?prereq0 ...) ?thunk)
+     (makefile-rule-md5-tmpvars () ?fingerprint ?target (?prereq0 ...) ?thunk))))
+
+(define-syntax makefile-rule-md5-tmpvars
+  (syntax-rules ()
+    ((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target () ?thunk)
+     ;; 
+     ;; ?target could be an expr: eval only once
+     ;; 
+     (let ((target ?target))
+       (lambda (rule-trans-set)
+	 (rule-trans-set-add! rule-trans-set
+			      target
+			      (list tmp1 ...)
+			      (make-has-md5-digest=? ?fingerprint target tmp1 ...)
+			      (lambda ?args (?thunk))))))
+    ;;
+    ;; recursively construct temporary, hygienic variables
+    ;;
+    ((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target 
+				(?prereq0 ?prereq1 ...) ?thunk)
+     (let ((tmp2 ?prereq0))
+       (makefile-rule-md5-tmpvars (tmp1 ... tmp2) ?fingerprint 
+				  ?target (?prereq1 ...) ?thunk)))))

rule-trans-set.scm

@@ -0,0 +1,89 @@
+;;;
+;;; RULE-TRANS-SET
+;;;
+;;; (make-empty-rule-trans-set) ---> rule-trans-set
+;;; 
+;;; (make-rule-trans-set rule-candidates known-rules rule-set)
+;;; 
+;;; (rule-trans-set-rule-candidates rts) ---> (rule-candidate0 ...)
+;;; (rule-trans-set-known-rules rts) ---> (known-rule0 ...)
+;;; (rule-trans-set-rule-set rts) ---> rule-set
+;;;
+;;; (rule-trans-set-add! rule-trans-set target prereqs wants-build? build-func)
+;;;   ---> rule-trans-set
+;;; 
+(define-record-type :rule-trans-set
+  (make-rule-trans-set rule-candidates known-rules rule-set)
+  is-rule-trans-set?
+  (rule-candidates rule-trans-set-rule-candidates)
+  (known-rules rule-trans-set-known-rules)
+  (rule-set rule-trans-set-rule-set))
+
+(define (make-empty-rule-trans-set)
+  (let ((rule-candidates '())
+	(known-rules (alist-cons '() '() '()))
+	(rule-set (make-empty-rule-set)))
+    (make-rule-trans-set rule-candidates known-rules rule-set)))
+
+(define (rule-trans-set-add! rule-trans-set target prereqs wants-build? build-func)
+  (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
+	(known-rules (rule-trans-set-known-rules rule-trans-set))
+        (rule-set (rule-trans-set-rule-set rule-trans-set)))
+    (rule-candidate-add! rule-candidates target prereqs wants-build? build-func)
+    (known-rules-update rule-trans-set)))
+
+;;; o  every incoming rule is considered as a rule-candidate so it is added
+;;;    here first
+(define (rule-candidate-add! rule-candidates target prereqs wants-build? build-func)
+  (set! rule-candidates 
+	(alist-cons target (list prereqs wants-build? build-func))))
+
+(define (rule-candidate-del! rule-candidates target)
+  (alist-delete! target rule-candidates))
+
+(define (rule-candidate-get rule-trans-set target)
+  (let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
+	 (maybe-rule-candidate (assq target rule-candidates)))
+    (if maybe-rule-candidate
+	(cons target (cdr (assq target rule-candidates)))
+	maybe-rule-candidate)))
+
+;;; o  if a target's prereqs are all in known-rules then the rule-candidate
+;;;    can be added to the known-rules as a freshly created rule
+;;; o  any rule-candidate with () as prereqs can be added to the known-rules
+;;;    as well, so this will be the first element of the known-rules
+(define (known-rules-add! rule-trans-set target prereqs wants-build? build-func)
+  (let ((rule (make-rule prereqs wants-build? build-func))
+	(known-rules (rule-trans-set-known-rules rule-trans-set))
+        (rule-set (rule-trans-set-rule-set rule-trans-set)))
+    (set! known-rules (alist-cons target rule known-rules))
+    (rule-set-add rule rule-set)))
+
+;;; look for all rule-candidates that can be added to known-rules
+(define (known-rules-update rule-trans-set)
+  (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
+	(known-rules (rule-trans-set-known-rules rule-trans-set))
+        (rule-set (rule-trans-set-rule-set rule-trans-set)))
+    (map (lambda (candidate-desc) 
+	   ;; 
+	   ;; candidate-desc is a list with these four elements 
+	   ;; target prereqs wants-build? build-func
+	   ;; 
+	   (apply (lambda (target prereqs wants-build? build-func)
+		    (if (not (memq #f (map (lambda (prereq) 
+					     (assq prereq known-rules))
+					   prereqs)))
+			(rule-candidate-del! rule-trans-set target)
+			(apply known-rules-add! (append (list rule-trans-set) 
+							candidate-desc))))
+		  candidate-desc))
+	 ;;
+	 ;; get the (target prereqs wants-build? build-func)-list
+	 ;; for each target
+	 ;;
+	 (map rule-candidate-get 
+	      ;;
+	      ;; get all targets 
+	      ;;
+	      (map car rule-candidates)))
+    (make-rule-trans-set rule-candidates known-rules rule-set)))