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

This commit is contained in:
jottbee 2005-01-21 09:09:31 +00:00
parent 053efed211
commit afb60fbb74
3 changed files with 78 additions and 28 deletions

View File

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

View File

@ -34,12 +34,7 @@
;;; o run known-rules-update afterwards ;;; o run known-rules-update afterwards
(define rule-trans-set-add (define rule-trans-set-add
(lambda (rule-trans-set target prereqs wants-build? build-func) (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 (define rule-candidate-add
(lambda (rule-trans-set target prereqs wants-build? build-func) (lambda (rule-trans-set target prereqs wants-build? build-func)
@ -103,6 +98,11 @@
(wants-build? (list-ref current-candidate-desc 2)) (wants-build? (list-ref current-candidate-desc 2))
(build-func (list-ref current-candidate-desc 3))) (build-func (list-ref current-candidate-desc 3)))
(let* ((known-rules (rule-trans-set-known-rules current-rts)) (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 (new-rts (if (not (memq #f
(map (lambda (prereq) (map (lambda (prereq)
(assoc prereq known-rules)) (assoc prereq known-rules))
@ -122,24 +122,3 @@
(if (or (= current-rcs last-rcs) (= current-rcs 0)) (if (or (= current-rcs last-rcs) (= current-rcs 0))
new-rts new-rts
(until-no-change current-rcs 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)))))

71
to-rule-set.scm Normal file
View File

@ -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