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

added start/stop threads; multiple rule-make commands do work now.

This commit is contained in:
jottbee 2005-02-25 08:14:37 +00:00
parent 208f3b47bc
commit 8ef87159b0
1 changed files with 65 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
make-rule.scm
View File

@ -64,17 +64,31 @@
(wants-build?-result rule-result-wants-build?)
(build-func-result rule-result-build-func))
(define (start-threads init-state rule-set)
(map (lambda (rule)
(let ((listen-ch (rule-set-get-listen-ch rule rule-set)))
(rule-node rule listen-ch init-state rule-set)))
(map car (rule-set-rules rule-set))))
(define (stop-threads init-state rule-set)
(map (lambda (rule)
(let* ((server (rule-set-get-listen-ch rule rule-set))
(client (send&collect/make-channel))
(link (make-link client server))
(recipient (car link))
(shutdown (make-tagged-msg recipient (rule-cmd shutdown))))
(send&collect/send client shutdown)))
(map car (rule-set-rules rule-set))))
(define (rule-make rule init-state rule-set)
(map (lambda (r)
(rule-node r (rule-set-get-listen-ch r rule-set) init-state rule-set))
(map car (rule-set-rules rule-set)))
(start-threads init-state rule-set)
(let* ((server (rule-set-get-listen-ch rule rule-set))
(client (send&collect/make-channel))
(link (make-link client server))
(recipient (car link)))
(send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
(let ((res (tagged-msg-stripped (send&collect/receive client))))
; (send&collect/send client (make-tagged-msg recipient (rule-cmd shutdown)))
(stop-threads init-state rule-set)
res)))
(define-enumerated-type rule-cmd :rule-cmd
@ -123,23 +137,45 @@
recipients)))
(rule-node/sort-msgs unsorted-msgs recipients)))
;;; named function for tracing
(define (apply-build-func build-required? rule prereqs prereqs-results cooked-state)
(let ((build-func (rule-build-func rule)))
(if (null? prereqs)
(build-func build-required? cooked-state)
(apply build-func
(append (list build-required?)
prereqs-results (list cooked-state))))))
;;; named function for tracing
(define (apply-wants-build? rule prereqs prereqs-results init-state)
(let ((wants-build? (rule-wants-build? rule)))
(if (null? prereqs)
(wants-build? init-state)
(apply wants-build? (append prereqs-results (list init-state))))))
(define (rule-node/make rule listen-ch connect-ch recipients init-state)
(let ((prereqs-results (rule-node/prereqs-results rule connect-ch recipients)))
(let ((wants-build?-result (if (null? prereqs-results)
((rule-wants-build? rule) init-state)
(apply (rule-wants-build? rule)
(append prereqs-results
(list init-state))))))
(let ((prereqs (rule-prereqs rule))
(prereqs-results (rule-node/prereqs-results rule connect-ch recipients)))
(let ((wants-build?-result
(apply-wants-build? rule prereqs prereqs-results init-state)))
;;; (let ((wants-build?-result (if (null? prereqs-results)
;;; ((rule-wants-build? rule) init-state)
;;; (apply (rule-wants-build? rule)
;;; (append prereqs-results
;;; (list init-state))))))
(let ((build-required? (car wants-build?-result))
(cooked-state (cdr wants-build?-result)))
(if build-required?
(let* ((build-func (rule-build-func rule))
(build-func-result (if (null? prereqs-results)
(build-func build-required? cooked-state)
(apply build-func
(append (list build-required?)
prereqs-results
(list cooked-state)))))
;;; (build-func-result (if (null? prereqs-results)
;;; (build-func build-required? cooked-state)
;;; (apply build-func
;;; (append (list build-required?)
;;; prereqs-results
;;; (list cooked-state)))))
(build-func-result
(apply-build-func build-required? rule prereqs
prereqs-results cooked-state))
(end-state (cdr build-func-result)))
(make-rule-result wants-build?-result build-func-result))
(make-rule-result wants-build?-result #f))))))
@ -152,6 +188,15 @@
(make-link connect-ch listen-ch))
listen-chs)))
;;; (define (lookup-target rule rule-alist)
;;; (let ((maybe-targets (filter (lambda (r) (eq? (cdr r) rule)) rule-alist)))
;;; (if (not (null? maybe-targets))
;;; (car (car maybe-targets))
;;; (error "lookup-target: rule not found in rule-alist."))))
;;;
;;; (define target/rule-alist '())
;;; (define (set!-target/rule-alist alist) (set! target/rule-alist alist))
(define (rule-node rule listen-ch init-state rule-set)
(let* ((connect-ch (send&collect/make-channel))
(get-rcpts (lambda ()
@ -165,11 +210,14 @@
(collect&reply/send listen-ch reply)))))
(spawn
(lambda ()
;;; (display (lookup-target rule target/rule-alist)) (newline)
(let node-loop ((tmsg (collect&reply/receive listen-ch))
(rcpts (get-rcpts)))
(cond
((eq? (rule-cmd-name (tagged-msg-stripped tmsg)) 'make)
(do-answer tmsg rcpts))
((eq? (rule-cmd-name (tagged-msg-stripped tmsg)) 'shutdown)
(terminate-current-thread))
(else (error "rule-node: no match")))
(node-loop (collect&reply/receive listen-ch) rcpts)))
'rule-node)))