*** empty log message ***
This commit is contained in:
jottbee
commit
9361340eab
|
|
@ -0,0 +1,28 @@
|
|||
# CVS default ignores begin
|
||||
tags
|
||||
TAGS
|
||||
.make.state
|
||||
.nse_depinfo
|
||||
*~
|
||||
\#*
|
||||
.#*
|
||||
,*
|
||||
_$*
|
||||
*$
|
||||
*.old
|
||||
*.bak
|
||||
*.BAK
|
||||
*.orig
|
||||
*.rej
|
||||
.del-*
|
||||
*.a
|
||||
*.olb
|
||||
*.o
|
||||
*.obj
|
||||
*.so
|
||||
*.exe
|
||||
*.Z
|
||||
*.elc
|
||||
*.ln
|
||||
core
|
||||
# CVS default ignores end
|
||||
|
|
@ -0,0 +1,276 @@
|
|||
(define-record-type :collect&reply-channel
|
||||
(collect&reply/really-make-channel cmd-in cmd-out from-server to-server)
|
||||
is-collect&reply-channel?
|
||||
(cmd-in collect&reply-channel-cmd-in)
|
||||
(cmd-out collect&reply-channel-cmd-out)
|
||||
(from-server collect&reply-channel-from-server)
|
||||
(to-server collect&reply-channel-to-server))
|
||||
|
||||
(define-record-type :send&collect-channel
|
||||
(send&collect/really-make-channel cmd-in cmd-out from-server to-server)
|
||||
is-send&collect-channel?
|
||||
(cmd-in send&collect-channel-cmd-in)
|
||||
(cmd-out send&collect-channel-cmd-out)
|
||||
(from-server send&collect-channel-from-server)
|
||||
(to-server send&collect-channel-to-server))
|
||||
|
||||
(define-enumerated-type collect&reply-cmd :collect&reply-cmd
|
||||
is-collect&reply-cmd?
|
||||
the-collect&reply-cmds
|
||||
collect&reply-cmd-name
|
||||
collect&reply-cmd-index
|
||||
(make-link))
|
||||
|
||||
(define-enumerated-type send&collect-cmd :send&collect-cmd
|
||||
is-send&collect-cmd?
|
||||
the-send&collect-cmds
|
||||
send&collect-cmd-name
|
||||
send&collect-cmd-index
|
||||
(make-link))
|
||||
|
||||
(define-record-type :tagged-msg
|
||||
(make-tagged-msg tag stripped)
|
||||
is-tagged-msg?
|
||||
(tag tagged-msg-tag)
|
||||
(stripped tagged-msg-stripped))
|
||||
|
||||
(define (collect&reply/tee2 from-server to-sink from-sink to-server in out)
|
||||
(let ((tmp-ch (cml-sync-ch/make-channel)))
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let ((tuid (thread-uid (current-thread))))
|
||||
(cml-sync-ch/send tmp-ch tuid)
|
||||
(let drink-tee ((collect-rv (cml-sync-ch/receive-rv from-sink))
|
||||
(reply-rv (cml-sync-ch/receive-rv from-server))
|
||||
(request-rv (cml-sync-ch/receive-rv in)))
|
||||
(cml-rv/select
|
||||
(cml-rv/wrap collect-rv
|
||||
(lambda (tmsg)
|
||||
;;; (display "tuid: ") (display tuid)
|
||||
;;; (display ". collect&reply/tee2: collect-rv.\n")
|
||||
(cml-sync-ch/send to-server tmsg)))
|
||||
(cml-rv/wrap reply-rv
|
||||
(lambda (tmsg)
|
||||
(let ((msg (tagged-msg-stripped tmsg))
|
||||
(tag (tagged-msg-tag tmsg)))
|
||||
;;; (display "tuid: ") (display tuid)
|
||||
;;; (display ". collect&reply/tee2: reply-rv.\n")
|
||||
(if (eq? tag tuid)
|
||||
(cml-sync-ch/send out msg)
|
||||
(if to-sink
|
||||
(cml-sync-ch/send to-sink tmsg))))))
|
||||
(cml-rv/wrap request-rv
|
||||
(lambda (msg)
|
||||
;;; (display "tuid: ") (display tuid)
|
||||
;;; (display ". collect&reply/tee2: request-rv.\n")
|
||||
(let ((tmsg (make-tagged-msg tuid msg)))
|
||||
(cml-sync-ch/send to-server tmsg)))))
|
||||
(drink-tee (cml-sync-ch/receive-rv from-sink)
|
||||
(cml-sync-ch/receive-rv from-server)
|
||||
(cml-sync-ch/receive-rv in))))
|
||||
'collect&reply/tee2))
|
||||
(cml-sync-ch/receive tmp-ch)))
|
||||
|
||||
(define (send&collect/tee2 from-server to-sink from-sink to-server in out)
|
||||
(let ((tmp-ch (cml-sync-ch/make-channel)))
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let ((tuid (thread-uid (current-thread))))
|
||||
(cml-sync-ch/send tmp-ch tuid)
|
||||
(let drink-tee ((collect-rv (cml-sync-ch/receive-rv from-sink))
|
||||
(send-rv (cml-sync-ch/receive-rv from-server))
|
||||
(reply-rv (cml-sync-ch/receive-rv in)))
|
||||
(cml-rv/select
|
||||
(cml-rv/wrap collect-rv
|
||||
(lambda (tmsg)
|
||||
;;; (display "tuid: ") (display tuid)
|
||||
;;; (display ". send&collect/tee2: collect-rv.\n")
|
||||
(cml-sync-ch/send to-server tmsg)))
|
||||
(cml-rv/wrap send-rv
|
||||
(lambda (tmsg)
|
||||
(let ((msg (tagged-msg-stripped tmsg))
|
||||
(tag (tagged-msg-tag tmsg)))
|
||||
;;; (display "tuid: ") (display tuid)
|
||||
;;; (display ". send&collect/tee2: send-rv.\n")
|
||||
(if (eq? tag tuid)
|
||||
(cml-sync-ch/send out msg)
|
||||
(if to-sink
|
||||
(cml-sync-ch/send to-sink tmsg))))))
|
||||
(cml-rv/wrap reply-rv
|
||||
(lambda (msg)
|
||||
;;; (display "tuid: ") (display tuid)
|
||||
;;; (display ". send&collect/tee2: reply-rv.\n")
|
||||
(let ((tmsg (make-tagged-msg tuid msg)))
|
||||
(cml-sync-ch/send to-server tmsg)))))
|
||||
(drink-tee (cml-sync-ch/receive-rv from-sink)
|
||||
(cml-sync-ch/receive-rv from-server)
|
||||
(cml-sync-ch/receive-rv in)))))
|
||||
'send&collect/tee2)
|
||||
(cml-sync-ch/receive tmp-ch)))
|
||||
|
||||
(define (collect&reply/server cmd-in cmd-out from-server to-server)
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let collect-or-reply ((cmd-rv (cml-sync-ch/receive-rv cmd-in))
|
||||
(collect-rv (cml-sync-ch/receive-rv to-server)))
|
||||
(cml-rv/select
|
||||
(cml-rv/wrap cmd-rv
|
||||
(lambda (cmd)
|
||||
(cond
|
||||
((and (is-collect&reply-cmd? cmd)
|
||||
(eq? (collect&reply-cmd-name cmd) 'make-link))
|
||||
(let* ((link-in (cml-sync-ch/receive cmd-in))
|
||||
(link-out (cml-sync-ch/receive cmd-in))
|
||||
(new-from-server (cml-sync-ch/make-channel))
|
||||
(new-to-server (cml-sync-ch/make-channel))
|
||||
(tuid (collect&reply/tee2 new-from-server
|
||||
from-server
|
||||
to-server
|
||||
new-to-server
|
||||
link-in
|
||||
link-out))
|
||||
(tmp-ch (cml-sync-ch/receive cmd-in)))
|
||||
;;; (display "collect&reply/server: cmd-rv, tuid: ")
|
||||
;;; (display (thread-uid (current-thread)))
|
||||
;;; (newline)
|
||||
(set! from-server new-from-server)
|
||||
(set! to-server new-to-server)
|
||||
(cml-sync-ch/send tmp-ch tuid)))
|
||||
((is-tagged-msg? cmd)
|
||||
;;; (display "collect&reply/server: cmd-rv, tuid: ")
|
||||
;;; (display (thread-uid (current-thread)))
|
||||
;;; (newline)
|
||||
(cml-sync-ch/send from-server cmd))
|
||||
(else
|
||||
(error "collect&reply: unsupported message type.")))))
|
||||
(cml-rv/wrap collect-rv
|
||||
(lambda (request)
|
||||
;;; (display "collect&reply/server: collect-rv, tuid: ")
|
||||
;;; (display (thread-uid (current-thread)))
|
||||
;;; (newline)
|
||||
(cml-sync-ch/send cmd-out request))))
|
||||
(collect-or-reply (cml-sync-ch/receive-rv cmd-in)
|
||||
(cml-sync-ch/receive-rv to-server))))
|
||||
'collect&reply/server))
|
||||
|
||||
(define (send&collect/server cmd-in cmd-out from-server to-server)
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let send-or-collect ((cmd-rv (cml-sync-ch/receive-rv cmd-in))
|
||||
(reply-rv (cml-sync-ch/receive-rv to-server)))
|
||||
(cml-rv/select
|
||||
(cml-rv/wrap cmd-rv
|
||||
(lambda (cmd)
|
||||
(cond
|
||||
((and (is-send&collect-cmd? cmd)
|
||||
(eq? (send&collect-cmd-name cmd) 'make-link))
|
||||
(let* ((link-in (cml-sync-ch/receive cmd-in))
|
||||
(link-out (cml-sync-ch/receive cmd-in))
|
||||
(new-from-server (cml-sync-ch/make-channel))
|
||||
(new-to-server (cml-sync-ch/make-channel))
|
||||
(tuid (send&collect/tee2 new-from-server
|
||||
from-server
|
||||
to-server
|
||||
new-to-server
|
||||
link-in
|
||||
link-out))
|
||||
(tmp-ch (cml-sync-ch/receive cmd-in)))
|
||||
;;; (display "send&collect/server: cmd-rv, tuid: ")
|
||||
;;; (display (thread-uid (current-thread)))
|
||||
;;; (newline)
|
||||
(set! from-server new-from-server)
|
||||
(set! to-server new-to-server)
|
||||
(cml-sync-ch/send tmp-ch tuid)))
|
||||
((is-tagged-msg? cmd)
|
||||
;;; (display "send&collect/server: cmd-rv, tuid: ")
|
||||
;;; (display (thread-uid (current-thread)))
|
||||
;;; (newline)
|
||||
(cml-sync-ch/send from-server cmd))
|
||||
(else
|
||||
(error "send&collect: unsupported message type.")))))
|
||||
(cml-rv/wrap reply-rv
|
||||
(lambda (reply)
|
||||
;;; (display "send&collect/server: reply-rv, tuid: ")
|
||||
;;; (display (thread-uid (current-thread)))
|
||||
;;; (newline)
|
||||
(cml-sync-ch/send cmd-out reply))))
|
||||
(send-or-collect (cml-sync-ch/receive-rv cmd-in)
|
||||
(cml-sync-ch/receive-rv to-server))))
|
||||
'send&collect/server))
|
||||
|
||||
(define (collect&reply/make-sink from-server to-server)
|
||||
(let ((to-sink #f)
|
||||
(from-sink (cml-sync-ch/make-channel))
|
||||
(link-in (cml-sync-ch/make-channel))
|
||||
(link-out (cml-sync-ch/make-channel)))
|
||||
(collect&reply/tee2 from-server to-sink from-sink to-server link-in link-out)))
|
||||
|
||||
(define (collect&reply/make-channel)
|
||||
(let ((cmd-in (cml-sync-ch/make-channel))
|
||||
(cmd-out (cml-sync-ch/make-channel))
|
||||
(from-server (cml-sync-ch/make-channel))
|
||||
(to-server (cml-sync-ch/make-channel)))
|
||||
(collect&reply/make-sink from-server to-server)
|
||||
(collect&reply/server cmd-in cmd-out from-server to-server)
|
||||
(collect&reply/really-make-channel cmd-in cmd-out from-server to-server)))
|
||||
|
||||
(define (send&collect/make-sink from-server to-server)
|
||||
(let ((to-sink #f)
|
||||
(from-sink (cml-sync-ch/make-channel))
|
||||
(link-in (cml-sync-ch/make-channel))
|
||||
(link-out (cml-sync-ch/make-channel)))
|
||||
(send&collect/tee2 from-server to-sink from-sink to-server link-in link-out)))
|
||||
|
||||
(define (send&collect/make-channel)
|
||||
(let ((cmd-in (cml-sync-ch/make-channel))
|
||||
(cmd-out (cml-sync-ch/make-channel))
|
||||
(from-server (cml-sync-ch/make-channel))
|
||||
(to-server (cml-sync-ch/make-channel)))
|
||||
(send&collect/make-sink from-server to-server)
|
||||
(send&collect/server cmd-in cmd-out from-server to-server)
|
||||
(send&collect/really-make-channel cmd-in cmd-out from-server to-server)))
|
||||
|
||||
(define (make-link from to)
|
||||
(let ((from-->to (cml-sync-ch/make-channel))
|
||||
(from<--to (cml-sync-ch/make-channel))
|
||||
(tmp-ch (cml-sync-ch/make-channel)))
|
||||
(cond
|
||||
((and (is-send&collect-channel? from)
|
||||
(is-collect&reply-channel? to))
|
||||
(cml-sync-ch/send (collect&reply-channel-cmd-in to)
|
||||
(collect&reply-cmd make-link))
|
||||
(cml-sync-ch/send (collect&reply-channel-cmd-in to) from-->to)
|
||||
(cml-sync-ch/send (collect&reply-channel-cmd-in to) from<--to)
|
||||
(cml-sync-ch/send (collect&reply-channel-cmd-in to) tmp-ch)
|
||||
(cml-sync-ch/receive tmp-ch)
|
||||
(cml-sync-ch/send (send&collect-channel-cmd-in from)
|
||||
(send&collect-cmd make-link))
|
||||
(cml-sync-ch/send (send&collect-channel-cmd-in from) from<--to)
|
||||
(cml-sync-ch/send (send&collect-channel-cmd-in from) from-->to)
|
||||
(cml-sync-ch/send (send&collect-channel-cmd-in from) tmp-ch)
|
||||
(cml-sync-ch/receive tmp-ch))
|
||||
(else (error "make-link: from/to has/have wrong type.")))))
|
||||
|
||||
(define (collect&reply/receive ch)
|
||||
(cml-sync-ch/receive (collect&reply-channel-cmd-out ch)))
|
||||
|
||||
(define (collect&reply/receive-rv ch)
|
||||
(cml-sync-ch/receive-rv (collect&reply-channel-cmd-out ch)))
|
||||
|
||||
(define (collect&reply/send ch msg)
|
||||
(cml-sync-ch/send (collect&reply-channel-cmd-in ch) msg))
|
||||
|
||||
(define (collect&reply/send-rv ch msg)
|
||||
(cml-sync-ch/send-rv (collect&reply-channel-cmd-in ch) msg))
|
||||
|
||||
(define (send&collect/send ch msg)
|
||||
(cml-sync-ch/send (send&collect-channel-cmd-in ch) msg))
|
||||
|
||||
(define (send&collect/send-rv ch msg)
|
||||
(cml-sync-ch/send-rv (send&collect-channel-cmd-in ch) msg))
|
||||
|
||||
(define (send&collect/receive ch)
|
||||
(cml-sync-ch/receive (send&collect-channel-cmd-out ch)))
|
||||
|
||||
(define (send&collect/receive-rv ch)
|
||||
(cml-sync-ch/receive-rv (send&collect-channel-cmd-out ch)))
|
||||
|
|
@ -0,0 +1,38 @@
|
|||
(define-record-type :rule
|
||||
(really-make-rule prereqs wants-build? build-func)
|
||||
is-rule?
|
||||
(prereqs rule-prereqs)
|
||||
(wants-build? rule-wants-build?)
|
||||
(build-func rule-build-func))
|
||||
|
||||
(define rules (list))
|
||||
(define lock-rules (make-lock))
|
||||
|
||||
(define (rule-make rule init-state)
|
||||
(let* ((res-pres (map (lambda (prereq)
|
||||
(rule-make prereq init-state))
|
||||
(rule-prereqs rule)))
|
||||
(res-wants-build? (call-with-values
|
||||
(lambda ()
|
||||
(apply values (append res-pres
|
||||
(list init-state))))
|
||||
(rule-wants-build? rule)))
|
||||
(build? (car res-wants-build?))
|
||||
(cooked-state (cdr res-wants-build?)))
|
||||
(if build?
|
||||
(call-with-values
|
||||
(lambda ()
|
||||
(apply values (append (list build?)
|
||||
res-pres
|
||||
(list cooked-state))))
|
||||
(rule-build-func rule))
|
||||
res-wants-build?)))
|
||||
|
||||
(define (make-rule prereqs wants-build? build-func)
|
||||
(let ((rule (really-make-rule prereqs wants-build? build-func)))
|
||||
(with-lock lock-rules
|
||||
(lambda ()
|
||||
(if (not (find (lambda (r) (eq? r rule)) rules))
|
||||
(set! rules (cons rule rules))
|
||||
(error "make-rule: rule already exists."))))
|
||||
rule))
|
||||
|
|
@ -0,0 +1,115 @@
|
|||
;;; TODO:
|
||||
;;; =====
|
||||
;;;
|
||||
;;; o Zyklenerkennung?
|
||||
;;; o nicht benoetigte Threads runterfahren
|
||||
|
||||
(define-record-type :rule
|
||||
(really-make-rule prereqs wants-build? build-func)
|
||||
is-rule?
|
||||
(prereqs rule-prereqs)
|
||||
(wants-build? rule-wants-build?)
|
||||
(build-func rule-build-func))
|
||||
|
||||
(define-enumerated-type rule-cmd :rule-cmd
|
||||
is-rule-cmd?
|
||||
the-rule-cmds
|
||||
rule-cmd-name
|
||||
rule-cmd-index
|
||||
(make link shutdown))
|
||||
|
||||
(define (rule-make rule init-state)
|
||||
(let* ((server (let ((found? (assq rule rules)))
|
||||
(if (is-collect&reply-channel? (cdr found?))
|
||||
(cdr found?)
|
||||
(error "rule-make: rule not found."))))
|
||||
(client (send&collect/make-channel))
|
||||
(recipient (make-link client server)))
|
||||
(send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
|
||||
(send&collect/send client (make-tagged-msg recipient init-state))
|
||||
(tagged-msg-stripped (send&collect/receive client))))
|
||||
|
||||
(define rules (list))
|
||||
(define lock-rules (make-lock))
|
||||
|
||||
(define (make-rule prereqs wants-build? build-func)
|
||||
(let ((rule (really-make-rule prereqs wants-build? build-func))
|
||||
(listen-ch (collect&reply/make-channel)))
|
||||
(with-lock lock-rules
|
||||
(lambda ()
|
||||
(if (not (assq rule rules))
|
||||
(begin
|
||||
(set! rules (alist-cons rule listen-ch rules))
|
||||
(rule-node rule listen-ch))
|
||||
(error "make-rule: rule already exists."))))
|
||||
rule))
|
||||
|
||||
(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))
|
||||
|
||||
(define (rule-node/make rule recipients connect-ch listen-ch init-state)
|
||||
(let* ((to-sort (map (lambda (recipient)
|
||||
(let ((tmsg-cmd (make-tagged-msg recipient
|
||||
(rule-cmd make)))
|
||||
(tmsg-state (make-tagged-msg recipient
|
||||
init-state)))
|
||||
(send&collect/send connect-ch tmsg-cmd)
|
||||
(send&collect/send connect-ch tmsg-state)
|
||||
(send&collect/receive connect-ch)))
|
||||
recipients))
|
||||
(res-pres (rule-node/sort-msgs to-sort recipients))
|
||||
(res-build? (call-with-values
|
||||
(lambda ()
|
||||
(apply values (append res-pres
|
||||
(list init-state))))
|
||||
(rule-wants-build? rule)))
|
||||
(res-wants-build? (car res-build?))
|
||||
(cooked-state (cdr res-build?)))
|
||||
(if res-wants-build?
|
||||
(let ((build-res (call-with-values
|
||||
(lambda ()
|
||||
(apply values (append (list res-wants-build?)
|
||||
res-pres
|
||||
(list cooked-state))))
|
||||
(rule-build-func rule))))
|
||||
build-res)
|
||||
(cons #t cooked-state))))
|
||||
|
||||
(define (rule-node/recipients rule connect-ch)
|
||||
(let ((server-chs (map (lambda (r)
|
||||
(with-lock lock-rules
|
||||
(lambda ()
|
||||
(cdr (assq r rules)))))
|
||||
(rule-prereqs rule))))
|
||||
(map (lambda (server-ch)
|
||||
(make-link connect-ch server-ch))
|
||||
server-chs)))
|
||||
|
||||
(define (rule-node rule listen-ch)
|
||||
(let ((connect-ch (send&collect/make-channel)))
|
||||
(spawn
|
||||
(lambda ()
|
||||
(let node-loop ((tmsg (collect&reply/receive listen-ch))
|
||||
(recipients #f))
|
||||
(let ((sender (tagged-msg-tag tmsg))
|
||||
(cmd (tagged-msg-stripped tmsg)))
|
||||
(cond
|
||||
((eq? (rule-cmd-name cmd) 'make)
|
||||
(if (not recipients)
|
||||
(set! recipients (rule-node/recipients rule connect-ch)))
|
||||
(let* ((tmsg (collect&reply/receive listen-ch))
|
||||
(init-state (tagged-msg-stripped tmsg))
|
||||
(res (rule-node/make rule recipients
|
||||
connect-ch listen-ch 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) recipients)))
|
||||
'rule-node)))
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
(makefile
|
||||
(makefile-rule "/home/johannes/.tmp/skills.tex"
|
||||
'()
|
||||
(lambda ()
|
||||
(with-cwd "/home/johannes/.tmp"
|
||||
(display "Top: /home/johannes/.tmp/skills.tex"))))
|
||||
(makefile-rule "/home/johannes/.tmp/skills.dvi"
|
||||
"/home/johannes/.tmp/skills.tex"
|
||||
(lambda ()
|
||||
(with-cwd "/home/johannes/.tmp"
|
||||
(begin
|
||||
(run (latex ,"/home/johannes/.tmp/skills.tex"))
|
||||
(run (dvicopy ,"/home/johannes/.tmp/skills.dvi"
|
||||
,"/home/johannes/.tmp/skills.dvicopy"))
|
||||
(rename-file "/home/johannes/.tmp/skills.dvicopy"
|
||||
"/home/johannes/.tmp/skills.dvi"
|
||||
#t)))))
|
||||
(makefile-rule "/home/johannes/.tmp/skills.pdf"
|
||||
"/home/johannes/.tmp/skills.dvi"
|
||||
(lambda ()
|
||||
(with-cwd "/home/johannes/.tmp"
|
||||
(run (dvipdfm -o ,"/home/johannes/.tmp/skills.pdf"
|
||||
,"/home/johannes/.tmp/skills.dvi"))))))
|
||||
|
||||
(make "/home/johannes/.tmp/skills.pdf")
|
||||
|
|
@ -0,0 +1,64 @@
|
|||
(define *fname->rule*-table '())
|
||||
|
||||
;;; (*fname->rule*-get fname) ---> rule
|
||||
(define (*fname->rule*-get fname)
|
||||
(let ((rule-found? (assoc fname *fname->rule*-table)))
|
||||
(if rule-found?
|
||||
(cdr rule-found?))))
|
||||
|
||||
;;; (*fname->rule*-add! fname) ---> {}
|
||||
(define (*fname->rule*-add! fname rule)
|
||||
(let ((rule-found? (assq fname *fname->rule*-table)))
|
||||
(if rule-found?
|
||||
(error "There already exists a rule with this fname!")
|
||||
(set! *fname->rule*-table
|
||||
(alist-cons fname rule *fname->rule*-table)))))
|
||||
|
||||
(define-syntax make-is-out-of-date?
|
||||
(syntax-rules ()
|
||||
((make-is-out-of-date? ?target '())
|
||||
(lambda ?args
|
||||
(cons (file-not-exists? ?target) ?args)))
|
||||
((make-is-out-of-date? ?target ?prereq0 ...)
|
||||
(lambda ?args
|
||||
(cons (or (file-not-exists? ?target)
|
||||
(> (file-last-mod ?prereq0)
|
||||
(file-last-mod ?target))
|
||||
...)
|
||||
(last ?args))))))
|
||||
|
||||
(define-syntax makefile-rule
|
||||
(syntax-rules ()
|
||||
((makefile-rule ?target '() ?action-thunk)
|
||||
(*fname->rule*-add! ?target
|
||||
(make-rule '()
|
||||
(make-is-out-of-date? ?target)
|
||||
(lambda ?args (?action-thunk)))))
|
||||
((makefile-rule ?target ?prereq0 ?action-thunk)
|
||||
(*fname->rule*-add! ?target
|
||||
(make-rule (list (*fname->rule*-get ?prereq0))
|
||||
(make-is-out-of-date? ?target ?prereq0)
|
||||
(lambda ?args (?action-thunk)))))
|
||||
((makefile-rule ?target (?prereq0 ...) ?action-thunk)
|
||||
(begin
|
||||
(*fname->rule*-add! ?target
|
||||
(make-rule (list (*fname->rule*-get ?prereq0)
|
||||
...)
|
||||
(make-is-out-of-date? ?target ?prereq0 ...)
|
||||
(lambda ?args (?action-thunk))))))
|
||||
((makefile-rule (?target0 ...) ?prereqs ?action-thunk)
|
||||
(begin
|
||||
(makefile-rule ?target0 ?prereqs ?action-thunk)
|
||||
...))))
|
||||
|
||||
(define-syntax makefile
|
||||
(syntax-rules ()
|
||||
; ((makefile ()) '())
|
||||
((makefile ?rule0 ...)
|
||||
(list ?rule0 ...))))
|
||||
|
||||
(define-syntax make
|
||||
(syntax-rules ()
|
||||
((make ?fname)
|
||||
(rule-make (*fname->rule*-get ?fname)
|
||||
"This is not an empty initial state."))))
|
||||
|
|
@ -0,0 +1,77 @@
|
|||
(define-interface collect-channels-interface
|
||||
(export make-tagged-msg
|
||||
is-tagged-msg?
|
||||
tagged-msg-tag
|
||||
tagged-msg-stripped
|
||||
collect&reply/make-channel
|
||||
send&collect/make-channel
|
||||
is-collect&reply-channel?
|
||||
is-send&collect-channel?
|
||||
make-link
|
||||
collect&reply/receive
|
||||
collect&reply/receive-rv
|
||||
collect&reply/send
|
||||
collect&reply/send-rv
|
||||
send&collect/send
|
||||
send&collect/send-rv
|
||||
send&collect/receive
|
||||
send&collect/receive-rv))
|
||||
|
||||
(define-structure collect-channels collect-channels-interface
|
||||
(open scheme-with-scsh
|
||||
finite-types
|
||||
srfi-9
|
||||
threads
|
||||
threads-internal
|
||||
(with-prefix rendezvous cml-rv/)
|
||||
(with-prefix rendezvous-channels cml-sync-ch/))
|
||||
(files collect-channels))
|
||||
|
||||
(define-interface make-rule-interface
|
||||
(export make-rule
|
||||
is-rule?
|
||||
rule-prereqs
|
||||
rule-wants-build?
|
||||
rule-build-func
|
||||
rule-make))
|
||||
|
||||
(define-structure make-rule make-rule-interface
|
||||
(open scheme-with-scsh
|
||||
locks
|
||||
with-lock
|
||||
threads
|
||||
srfi-1
|
||||
srfi-9
|
||||
finite-types
|
||||
collect-channels
|
||||
(with-prefix rendezvous cml-rv/)
|
||||
(with-prefix rendezvous-channels cml-sync-ch/))
|
||||
(files make-rule))
|
||||
|
||||
(define-interface make-rule-no-cml-interface
|
||||
(export make-rule
|
||||
is-rule?
|
||||
rule-prereqs
|
||||
rule-wants-build?
|
||||
rule-build-func
|
||||
rule-make))
|
||||
|
||||
(define-structure make-rule-no-cml make-rule-no-cml-interface
|
||||
(open scheme-with-scsh
|
||||
locks
|
||||
with-lock
|
||||
srfi-1
|
||||
srfi-9)
|
||||
(files make-rule-no-cml))
|
||||
|
||||
(define-interface makros-interface
|
||||
(export (make-is-out-of-date? :syntax)
|
||||
(makefile :syntax)
|
||||
(makefile-rule :syntax)
|
||||
(make :syntax)))
|
||||
|
||||
(define-structure makros makros-interface
|
||||
(open scheme-with-scsh
|
||||
srfi-1
|
||||
make-rule)
|
||||
(files makros))
|
||||
Loading…
Reference in New Issue