scsh-conservatory
/
scsh-make
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

make-rule now uses the sort function of dfs, added the predicate 

function position< therefore and changed the rule-node/sort-msgs
function accordingly.
fixed rule-node/make: now prereqs-results is checked for being an
empty list -> init-state is now passed properly, prereqs-results are
well-formed now. apply is only used for non-empty prereqs-results
(then the number of prereqs is unknown here).
This commit is contained in:
jottbee 2005-02-14 07:13:14 +00:00
parent 2479676e2d
commit b4382fa7b7
1 changed files with 48 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
make-rule.scm
View File

@ -86,51 +86,61 @@
rule-cmd-index rule-cmd-index
(make link shutdown)) (make link shutdown))
(define (rule-node/sort-msgs unsorted to-order) (define (position< maybe-lesser maybe-greater objects)
(map (lambda (pos) (if (null? objects)
(map (lambda (tmsg) (error "position< has empty objects-list.")
(let ((msg (tagged-msg-stripped tmsg)) (let search-objects ((current (car objects))
(sender (tagged-msg-tag tmsg))) (todo (cdr objects)))
(if (eq? sender pos) (cond
msg))) ((= (tagged-msg-tag maybe-lesser) current) #t)
unsorted)) ((= (tagged-msg-tag maybe-greater) current) #f)
to-order)) ((null? todo)
(error "position< maybe-lesser or maybe-greater not found."))
(else (search-objects (car todo) (cdr todo)))))))
;;; send each prereq-thread a make command and the init-state (define (rule-node/sort-msgs unsorted to-order)
;;; then wait for the results to return (map tagged-msg-stripped
;;; sort to the order they were sent and ciao (sort (lambda (maybe-lesser maybe-greater)
(define (rule-node/get-prereqs-results rule connect-ch recipients init-state) (position< maybe-lesser maybe-greater to-order))
(rule-node/sort-msgs (map unsorted (list))))
(lambda (recipient)
(send&collect/send connect-ch (define (rule-node/prereqs-results rule connect-ch recipients)
(make-tagged-msg recipient (let ((unsorted-msgs (map (lambda (recipient)
(rule-cmd make))) (let ((tmsg (make-tagged-msg recipient
(send&collect/receive connect-ch)) (rule-cmd make))))
recipients) (send&collect/send connect-ch tmsg)
recipients)) (send&collect/receive connect-ch)))
recipients)))
(rule-node/sort-msgs unsorted-msgs recipients)))
(define (rule-node/make rule listen-ch connect-ch recipients init-state) (define (rule-node/make rule listen-ch connect-ch recipients init-state)
(let* ((prereqs-results (rule-node/get-prereqs-results rule connect-ch (let ((prereqs-results (rule-node/prereqs-results rule connect-ch recipients)))
recipients init-state)) (let ((wants-build?-result (if (null? prereqs-results)
(wants-build?-result (apply (rule-wants-build? rule) ((rule-wants-build? rule) init-state)
(append prereqs-results (list init-state)))) (apply (rule-wants-build? rule)
(build-required? (car wants-build?-result)) (append prereqs-results
(cooked-state (cdr wants-build?-result))) (list init-state))))))
(if build-required? (let ((build-required? (car wants-build?-result))
(make-rule-result wants-build?-result (cooked-state (cdr wants-build?-result)))
(apply (rule-build-func rule) (if build-required?
(append (list build-required?) (if (null? prereqs-results)
prereqs-results (make-rule-result wants-build?-result
(list cooked-state)))) ((rule-build-func rule)
(make-rule-result wants-build?-result #f)))) build-required? cooked-state))
(make-rule-result wants-build?-result
(apply (rule-build-func rule)
(append (list build-required?)
prereqs-results
(list cooked-state)))))
(make-rule-result wants-build?-result #f))))))
(define (rule-node/make-links rule connect-ch rule-set) (define (rule-node/make-links rule connect-ch rule-set)
(let ((listen-chs (map (lambda (r) (let ((listen-chs (map (lambda (r)
(cdr (assq r (rule-set-rules rule-set)))) (cdr (assq r (rule-set-rules rule-set))))
(rule-prereqs rule)))) (rule-prereqs rule))))
(map (lambda (listen-ch) (map (lambda (listen-ch)
(make-link connect-ch listen-ch)) (make-link connect-ch listen-ch))
listen-chs))) listen-chs)))
(define (rule-node rule listen-ch init-state rule-set) (define (rule-node rule listen-ch init-state rule-set)
(let ((connect-ch (send&collect/make-channel))) (let ((connect-ch (send&collect/make-channel)))