161 lines
5.1 KiB
Scheme
161 lines
5.1 KiB
Scheme
;;;
|
|
;;; RULE
|
|
;;;
|
|
;;; (make-rule prereqs wants-build? build-func) ---> rule
|
|
;;;
|
|
;;; prereqs: '(#{:rule} ...)
|
|
;;; wants-build?: (lambda (res-p0 res-p1 ... res-pN init-state) body ...)
|
|
;;; res-pX: result of prerequisite-rule no. X
|
|
;;; (wants-build? res-p0 ... res-pN init-state)
|
|
;;; ---> (res-wants-build? . cooked-state)
|
|
;;; build-func:
|
|
;;; (lambda (res-wants-build? res-p0 ... res-pN cooked-state)
|
|
;;; ---> (res-build-func . end-state)
|
|
;;;
|
|
(define-record-type :rule
|
|
(make-rule prereqs wants-build? build-func)
|
|
is-rule?
|
|
(prereqs rule-prereqs)
|
|
(wants-build? rule-wants-build?)
|
|
(build-func rule-build-func))
|
|
|
|
;;;
|
|
;;; RULE-SET
|
|
;;;
|
|
;;; (make-empty-rule-set) ---> rule-set
|
|
;;; (rule-set-add rule rule-set) ---> rule-set
|
|
;;;
|
|
(define-record-type :rule-set
|
|
(make-rule-set rules)
|
|
is-rule-set?
|
|
(rules rule-set-rules))
|
|
|
|
(define (make-empty-rule-set)
|
|
(make-rule-set '()))
|
|
|
|
(define (rule-set-add rule rule-set)
|
|
(let ((listen-ch (collect&reply/make-channel)))
|
|
(if (not (assq rule (rule-set-rules rule-set)))
|
|
(make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set)))
|
|
(error "make-rule: rule already exists."))))
|
|
|
|
(define (rule-set-get-listen-ch rule rule-set)
|
|
(let ((?thing (assq rule (rule-set-rules rule-set))))
|
|
(if (and ?thing (pair? ?thing) (is-collect&reply-channel? (cdr ?thing)))
|
|
(cdr ?thing)
|
|
(error "Rule not found in rule-set."))))
|
|
|
|
;;;
|
|
;;; RULE-RESULT
|
|
;;;
|
|
;;; (rule-result-wants-build? rule-result) --->
|
|
;;; (wants-build?-result . cooked-state) oder (#f . cooked-state)
|
|
;;;
|
|
;;; (rule-result-build-func rule-result) --->
|
|
;;; (build-func-result . end-state) oder #f
|
|
;;;
|
|
;;; (rule-make rule init-state rule-set) ---> rule-result
|
|
;;;
|
|
(define-record-type :rule-result
|
|
(make-rule-result wants-build?-result build-func-result)
|
|
is-rule-result?
|
|
(wants-build?-result rule-result-wants-build?)
|
|
(build-func-result rule-result-build-func))
|
|
|
|
(define (rule-make rule init-state rule-set)
|
|
;;
|
|
;; this could be rewritten in future
|
|
;;
|
|
;; check for unused threads -> dont start them
|
|
;;
|
|
(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)))
|
|
(let* ((server (rule-set-get-listen-ch rule rule-set))
|
|
(client (send&collect/make-channel))
|
|
(recipient (make-link client server)))
|
|
(send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
|
|
(tagged-msg-stripped (send&collect/receive client))))
|
|
|
|
(define-enumerated-type rule-cmd :rule-cmd
|
|
is-rule-cmd?
|
|
the-rule-cmds
|
|
rule-cmd-name
|
|
rule-cmd-index
|
|
(make link shutdown))
|
|
|
|
(define (rule-node/sort-msgs unsorted to-order)
|
|
(map (lambda (pos)
|
|
(map (lambda (tmsg)
|
|
(let ((msg (tagged-msg-stripped tmsg))
|
|
(sender (tagged-msg-tag tmsg)))
|
|
(if (eq? sender pos)
|
|
msg)))
|
|
unsorted))
|
|
to-order))
|
|
|
|
;;; send each prereq-thread a make command and the init-state
|
|
;;; then wait for the results to return
|
|
;;; sort to the order they were sent and ciao
|
|
(define (rule-node/get-prereqs-results rule connect-ch recipients init-state)
|
|
(rule-node/sort-msgs (map
|
|
(lambda (recipient)
|
|
(send&collect/send connect-ch
|
|
(make-tagged-msg recipient
|
|
(rule-cmd make)))
|
|
(send&collect/receive connect-ch))
|
|
recipients)
|
|
recipients))
|
|
|
|
(define (rule-node/make rule listen-ch connect-ch recipients init-state)
|
|
(let* ((prereqs-results (rule-node/get-prereqs-results rule connect-ch
|
|
recipients init-state))
|
|
(wants-build?-result (apply (rule-wants-build? rule)
|
|
(append prereqs-results (list init-state))))
|
|
(build-required? (car wants-build?-result))
|
|
(cooked-state (cdr wants-build?-result)))
|
|
(if build-required?
|
|
(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)
|
|
(let ((listen-chs (map (lambda (r)
|
|
(cdr (assq r (rule-set-rules rule-set))))
|
|
(rule-prereqs rule))))
|
|
(map (lambda (listen-ch)
|
|
(make-link connect-ch listen-ch))
|
|
listen-chs)))
|
|
|
|
(define (rule-node rule listen-ch init-state rule-set)
|
|
(let ((connect-ch (send&collect/make-channel)))
|
|
(spawn
|
|
(lambda ()
|
|
;;
|
|
;; wait for anything on the listen-ch
|
|
;; check if it is a known command
|
|
;; if so: process this command
|
|
;; otherwise it was noise
|
|
;;
|
|
;; if its the first time the make command drops in
|
|
;; initially make the connections to every prereq-listen-ch
|
|
;;
|
|
(let node-loop ((tmsg (collect&reply/receive listen-ch))
|
|
(maybe-recipients #f))
|
|
(let ((sender (tagged-msg-tag tmsg))
|
|
(cmd (tagged-msg-stripped tmsg)))
|
|
(cond
|
|
((eq? (rule-cmd-name cmd) 'make)
|
|
(if (not maybe-recipients)
|
|
(set! maybe-recipients
|
|
(rule-node/make-links rule connect-ch rule-set)))
|
|
(let ((res (rule-node/make rule listen-ch connect-ch
|
|
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) maybe-recipients)))
|
|
'rule-node)))
|