*** empty log message ***

macros.scm

@@ -1,25 +1,95 @@
+;;; TODO:
+;;; 
+;;; macros -> functions, eg.
+;;; 
+;;; (define make-is-out-of-date!
+;;;  (lambda (t . p) 
+;;;     (lambda args (cons #t (last args)))))
+
 (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)))
+     ;; ?rule-trans-set could be an expr: eval only once
-	 (if (not (null? (rule-trans-set-rule-candidates ?rule-trans-set)))
+     ;; 
-	     (display "warning: rule-candidates not empty!\n"))
+     (let ((rule-trans-set ?rule-trans-set))
+       (let ((target-rule (known-rules-get rule-trans-set ?target-fname0)))
 	 (if target-rule
 	     (rule-make target-rule
 			?init-state
-			(rule-trans-set-rule-set ?rule-trans-set))
+			(rule-trans-set-rule-set rule-trans-set))
 	     (error "target-rule not found in rule-set.")))
-       ...))))
+       ...))
+    ((_ ) (error "usage: (make '#{:rule-trans-set} (target0 ...) init-state)\n"))))
 
 (define-syntax makefile
   (syntax-rules () 
     ((makefile ?rule0 ...)
      (let ((rule-trans-set (make-empty-rule-trans-set)))
-       (let ((rule-trans-set (?rule0 rule-trans-set)))
+       (let* ((rule-trans-set (?rule0 rule-trans-set))
-	 ...
+	      ...)
 	 rule-trans-set)))))
 
+;;; (define-syntax makefile
+;;;   (syntax-rules () 
+;;;     ((makefile) (make-empty-rule-trans-set))
+;;;     ((makefile ?rule0 ?rule1 ...)
+;;;      (?rule0 (makefile ?rule1 ...)))))
+
+(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)))))
+
 (define-syntax make-is-out-of-date? 
   (syntax-rules () 
     ((make-is-out-of-date? ?target)
@@ -55,56 +125,3 @@
 		     (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)))))

make-rule.scm

@@ -144,17 +144,17 @@
 	;; initially make the connections to every prereq-listen-ch
 	;; 
 	(let node-loop ((tmsg (collect&reply/receive listen-ch))
-			(?recipients #f))
+			(maybe-recipients #f))
 	  (let ((sender (tagged-msg-tag tmsg))
 		(cmd (tagged-msg-stripped tmsg)))
 	    (cond
 	     ((eq? (rule-cmd-name cmd) 'make)
-	      (if (not ?recipients) 
+	      (if (not maybe-recipients) 
-		  (set! ?recipients 
+		  (set! maybe-recipients 
 			(rule-node/make-links rule connect-ch rule-set)))
 	      (let ((res (rule-node/make rule listen-ch connect-ch 
-					 ?recipients init-state)))
+					 maybe-recipients init-state)))
 		(collect&reply/send listen-ch (make-tagged-msg sender res))))
 	     ((eq? (rule-cmd-name cmd) 'shutdown) (terminate-current-thread))))
-	  (node-loop (collect&reply/receive listen-ch) ?recipients)))
+	  (node-loop (collect&reply/receive listen-ch) maybe-recipients)))
       'rule-node)))

makefile.scm

@@ -1,24 +1,28 @@
-;;; (define d (expand-file-name "~/.tmp"))
+;;; (define work-dir (expand-file-name "~/.tmp"))
 ;;; 
+;;; (make 
 ;;;     (makefile
-;;;  (makefile-rule (expand-file-name "skills.tex" d)
+;;;      (makefile-rule (expand-file-name "skills.tex" work-dir)
 ;;; 		    ()
 ;;; 		    (lambda ()
-;;; 		  (with-cwd d (display "Top: skills.tex"))))
+;;; 		      (with-cwd work-dir (display "Top: skills.tex"))))
-;;;  (makefile-rule (expand-file-name "skills.dvi" d)
+;;;      (makefile-rule (expand-file-name "skills.dvi" work-dir)
-;;; 		(expand-file-name "skills.tex" d)
+;;; 		    ((expand-file-name "skills.tex" work-dir))
 ;;; 		    (lambda ()
-;;; 		  (with-cwd d
+;;; 		      (with-cwd 
-;;; 			    (run (latex ,(expand-file-name "skills.tex" d))))))
+;;; 		       work-dir
-;;;  (makefile-rule (expand-file-name "skills.pdf" d)
+;;; 		       (run (latex ,(expand-file-name "skills.tex" work-dir))))))
-;;; 		(expand-file-name "skills.dvi" d)
+;;;      (makefile-rule (expand-file-name "skills.pdf" work-dir)
+;;; 		    ((expand-file-name "skills.dvi" work-dir))
 ;;; 		    (lambda ()
-;;; 		  (with-cwd d (run 
+;;; 		      (with-cwd 
+;;; 		       work-dir 
+;;; 		       (run 
 ;;; 			(dvipdfm -o 
-;;; 					,(expand-file-name "skills.pdf" d)
+;;; 				 ,(expand-file-name "skills.pdf" work-dir)
-;;; 					,(expand-file-name "skills.dvi" d)))))))
+;;; 				 ,(expand-file-name "skills.dvi" work-dir)))))))
-;;; 
+;;;   ((expand-file-name "skills.pdf" work-dir))
-;;; (make (expand-file-name "skills.pdf" d) "this is an empty init-state")
+;;;   "this is an empty init-state")
 
 (make 
   (makefile
@@ -38,5 +42,7 @@
 		    (with-cwd "/home/bruegman/.tmp"
 			      (run (dvipdfm -o ,"/home/bruegman/.tmp/skills.pdf"
 					    ,"/home/bruegman/.tmp/skills.dvi"))))))
-  ("/home/bruegman/.tmp/skills.pdf")
+   ("/home/bruegman/.tmp/skills.pdf" 
+    "/home/bruegman/.tmp/skills.dvi"
+    "/home/bruegman/.tmp/skills.tex")
    "this is an empty init-state...")

packages.scm

@@ -189,8 +189,9 @@
 	  rule-trans-set-rule-candidates
 	  rule-trans-set-known-rules
 	  rule-trans-set-rule-set
-	  rule-trans-set-add!
+	  rule-trans-set-add
-	  rule-candidate-get))
+	  rule-candidate-get
+	  known-rules-get))
 
 (define-structure rule-trans-set rule-trans-set-interface
   (open scheme-with-scsh

rule-trans-set.scm

@@ -1,3 +1,7 @@
+;;; TODO:
+;;; 
+;;; change to topological sort
+
 ;;;
 ;;; RULE-TRANS-SET
 ;;;
@@ -25,24 +29,35 @@
 	(rule-set (make-empty-rule-set)))
     (make-rule-trans-set rule-candidates known-rules rule-set)))
 
-(define rule-trans-set-add! 
+;;; o  every incoming rule is considered as a rule-candidate
+;;; o  add the new rule-candidate to rule-candidates
+;;; o  run known-rules-update afterwards
+(define rule-trans-set-add
   (lambda (rule-trans-set target prereqs wants-build? build-func)
-    (let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
+    (known-rules-update 
+     (rule-candidate-add rule-trans-set 
+			 target 
+			 prereqs 
+			 wants-build? 
+			 build-func))))
+
+(define rule-candidate-add 
+  (lambda (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))
-	   (args (list rule-candidates target prereqs wants-build? build-func)))
+	  (rule-args (list prereqs wants-build? build-func)))
-      (apply rule-candidate-add! args)
+      (make-rule-trans-set (alist-cons target rule-args rule-candidates)
-      (known-rules-update rule-trans-set))))
+			   known-rules
+			   rule-set))))
 
-;;; o  every incoming rule is considered as a rule-candidate so it is added
+(define (rule-candidate-del rule-trans-set target)
-;;;    here first
+  (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
-(define rule-candidate-add! 
+	(known-rules (rule-trans-set-known-rules rule-trans-set))
-  (lambda (rule-candidates target prereqs wants-build? build-func)
+	(rule-set (rule-trans-set-rule-set rule-trans-set)))
-    (let ((rule-args (list prereqs wants-build? build-func)))
+    (make-rule-trans-set (alist-delete! target rule-candidates)
-      (set! rule-candidates (alist-cons target rule-args rule-candidates)))))
+			 known-rules
-
+			 rule-set)))
-(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))
@@ -55,40 +70,69 @@
 ;;;    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)
+(define known-rules-add
-  (let ((rule (make-rule prereqs wants-build? build-func))
+  (lambda (rule-trans-set target prereqs wants-build? build-func)
+    (let ((rule (make-rule (map (lambda (prereq)
+				  (known-rules-get rule-trans-set prereq))
+				prereqs)
+			   wants-build? 
+			   build-func))
 	  (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)))
-    (set! known-rules (alist-cons target rule known-rules))
       (make-rule-trans-set rule-candidates 
-			 known-rules 
+			   (alist-cons target rule known-rules)
-			 (rule-set-add rule rule-set))))
+			   (rule-set-add rule rule-set)))))
+
+(define (known-rules-get rule-trans-set target)
+  (let* ((known-rules (rule-trans-set-known-rules rule-trans-set))
+         (maybe-rule (assq target known-rules)))
+    (if maybe-rule (cdr maybe-rule) maybe-rule)))
+
+(define (known-rules-update rule-trans-set)
+  (let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
+	 (candidate-descs (map cons (map car rule-candidates) 
+			            (map cdr rule-candidates))))
+    (let for-candidates ((current-candidate-desc (car candidate-descs))
+			 (to-do-candidate-desc (cdr candidate-descs))
+			 (current-rts rule-trans-set))
+      (let ((target (list-ref current-candidate-desc 0))
+	    (prereqs (list-ref current-candidate-desc 1))
+	    (wants-build? (list-ref current-candidate-desc 2))
+	    (build-func (list-ref current-candidate-desc 3)))
+	(let* ((known-rules (rule-trans-set-known-rules current-rts))
+	       (new-rts (if (not (memq #f (map (lambda (prereq) 
+						 (assq prereq known-rules))
+					       prereqs)))
+			    (known-rules-add (rule-candidate-del current-rts target)
+					     target
+					     prereqs
+					     wants-build?
+					     build-func)
+			    current-rts)))
+	  (if (not (null? to-do-candidate-desc))
+	      (for-candidates (car to-do-candidate-desc)
+			      (cdr to-do-candidate-desc)
+			      new-rts)
+	      new-rts))))))
 
 ;;; look for all rule-candidates that can be added to known-rules
-(define (known-rules-update rule-trans-set)
+;;; and add them to known-rules
-  (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set)))
+;;; (define (known-rules-update rule-trans-set)
-    (map (lambda (candidate-desc) 
+;;;   (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set)))
-	   (apply (lambda (target prereqs wants-build? build-func)
+;;;     (map (lambda (candidate-desc) 
-		    (let ((rules (rule-trans-set-known-rules rule-trans-set)))
+;;; 	   (apply (lambda (target prereqs wants-build? build-func)
-		      (if (not (memq #f (map (lambda (prereq) 
+;;; 		    (let ((rules (rule-trans-set-known-rules rule-trans-set)))
-					       (assq prereq rules))
+;;; 		      (if (not (memq #f (map (lambda (prereq) 
-					     prereqs)))
+;;; 					       (assq prereq rules))
-			  (begin 
+;;; 					     prereqs)))
-			    (rule-candidate-del! rule-trans-set target)
+;;; 			  (set! rule-trans-set
-			    (set! rule-trans-set 
+;;; 				(apply known-rules-add! 
-				  (apply known-rules-add! 
+;;; 				       (append (list (rule-candidate-del
-					 (append (list rule-trans-set)
+;;; 						      rule-trans-set
-						 candidate-desc))))
+;;; 						      target))
-			  rule-trans-set)))
+;;; 					       candidate-desc))))
-		    candidate-desc))
+;;; 			  rule-trans-set))
-	 ;;
+;;; 		    candidate-desc))
-	 ;; get the (target prereqs wants-build? build-func)-list
+;;; 	 (map cons (map car rule-candidates) (map cdr rule-candidates)))))
-	 ;; for each target
+
-	 ;;
-	 (map (lambda (target) 
-		(rule-candidate-get rule-trans-set target))
-	      ;;
-	      ;; get all targets 
-	      ;;
-	      (map car rule-candidates)))))