to-rule-set.scm: future replacement for rule-trans-set.scm,\n depth-first-search will be called from here.

macros.scm

@@ -12,7 +12,7 @@
      ;; 
      ;; ?rule-trans-set or ?target-fname0 could be an expr: eval only once
      ;; 
-     (let ((rule-trans-set ?rule-trans-set))
+     (let ((rule-trans-set (known-rules-update ?rule-trans-set)))
        (let* ((target-fname0 ?target-fname0)
 	      (target-rule (known-rules-get rule-trans-set target-fname0)))
 	 (if (not (null? (rule-trans-set-rule-candidates rule-trans-set)))

rule-trans-set.scm

@@ -34,12 +34,7 @@
 ;;; o  run known-rules-update afterwards
 (define rule-trans-set-add
   (lambda (rule-trans-set target prereqs wants-build? build-func)
-    (known-rules-update 
+    (rule-candidate-add rule-trans-set target prereqs wants-build? build-func)))
-     (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)
@@ -103,6 +98,11 @@
 	      (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))
+		 ;;
+		 ;; if all prereqs of a target are in known-rules
+		 ;; then the rule-candidate can be added to the known-rules
+		 ;; after its deletion of the rule-candidates
+		 ;;
 		 (new-rts (if (not (memq #f 
 					 (map (lambda (prereq) 
 						(assoc prereq known-rules))
@@ -122,24 +122,3 @@
 		  (if (or (= current-rcs last-rcs) (= current-rcs 0))
 		      new-rts
 		      (until-no-change current-rcs new-rts))))))))))
-
-;;; look for all rule-candidates that can be added to known-rules
-;;; and add them to known-rules
-;;; (define (known-rules-update rule-trans-set)
-;;;   (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set)))
-;;;     (map (lambda (candidate-desc) 
-;;; 	   (apply (lambda (target prereqs wants-build? build-func)
-;;; 		    (let ((rules (rule-trans-set-known-rules rule-trans-set)))
-;;; 		      (if (not (memq #f (map (lambda (prereq) 
-;;; 					       (assq prereq rules))
-;;; 					     prereqs)))
-;;; 			  (set! rule-trans-set
-;;; 				(apply known-rules-add! 
-;;; 				       (append (list (rule-candidate-del
-;;; 						      rule-trans-set
-;;; 						      target))
-;;; 					       candidate-desc))))
-;;; 			  rule-trans-set))
-;;; 		    candidate-desc))
-;;; 	 (map cons (map car rule-candidates) (map cdr rule-candidates)))))
-

to-rule-set.scm

@@ -0,0 +1,71 @@
+(define-record-type :rc-set
+  (make-rc-set rule-candidates fname-rule-table rule-set)
+  is-rc-set?
+  (rule-candidates rc-set-rule-candidates)
+  (fname-rule-table rc-set-fname-rule-table)
+  (rule-set rc-set-rule-set))
+
+(define-enumerated-type color :color
+  is-color?
+  the-color
+  color-name
+  color-index
+  (white grey black))
+
+(define-record-type :dfs-data
+  (make-dfs-data rc color discovery-time finishing-time predecessor)
+  is-dfs-data?
+  (rc dfs-data-rc)
+  (color dfs-data-color)
+  (discovery-time dfs-data-discovery-time)
+  (finishing-time dfs-data-finishing-time)
+  (predecessor dfs-data-predecessor))
+
+(define (dfs-timer ch)
+  (spawn
+    (lambda ()
+      (let timer-loop ((current-time 0))
+	(cml-sync-ch/receive ch)
+	(cml-sync-ch/send ch current-time)
+	(timer-loop (+ current-time 1))))))
+
+(define (dfs-time ch)
+  (cml-sync-ch/send ch 'get-time)
+  (cml-sync-ch/receive ch))
+
+(define (dfs-lookup-prereq rc-set prereq)
+  (let ((maybe-rc (assoc prereq (rc-set-rule-candidates rc-set))))
+    (if maybe-rc (car 
+
+(define (dfs-visit node time-ch)
+  (set! (dfs-data-color node) (color grey))
+  (set! (dfs-data-discovery-time node) (dfs-time time-ch))
+  (for-each (lambda (prereq)
+	      (if (eq? (dfs-data-color prereq) (color white))
+		  (begin 
+		    (set! (dfs-data-predecessor prereq) node)
+		    (dfs-visit prereq time))))
+	    ;; rule-candidates:
+	    ;; ((target . (prereqs wants-build? build-func)) ...)
+	    ;; lookup the node for prereq
+	    (map dfs-lookup-prereq
+		 (cadr (rc-set-rule-candidates (dfs-data-rc node))))
+  (set! (dfs-data-color node) (color black))
+  (set! (dfs-data-discovery-time node) (dfs-time time-ch))
+
+;;; this is the depth first search algorithm
+(define (dfs rc-set)
+  (let* ((rule-candidates (rc-set-rule-candidates rc-set))
+	 (fname-rule-table (rc-set-fname-rule-table rc-set))
+	 (rule-set (rc-set-rule-set rc-set))
+	 (rc-dfs-data (map (lambda (rc) (make-dfs-data rc (color white) 0 0 #f))
+			   rule-candidates))
+	 (time 0))
+
+    (
+
+    (if (not (null? rc-dfs-data))
+	(let visit-each-rc ((current-rc (car rc-dfs-data))
+			    (to-visit-rcs (cdr rc-dfs-data)))
+	  (if (eq? (color-name (dfs-data-color dfs-data)) (color white))
+	      (begin