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

Compare commits

base: scsh-conservatory:main
Branches Tags
scsh-conservatory:main
scsh-conservatory:import-1.1.1
scsh-conservatory:start
..
compare: scsh-conservatory:import-1.1.1
Branches Tags
scsh-conservatory:main
scsh-conservatory:import-1.1.1
scsh-conservatory:start

2 Commits
main ... import-1.1

Author SHA1 Message Date
jottbee 50eb6e3000 Initial import. 2005-01-17 07:56:42 +00:00
jottbee 52d770599b Initial import. 2005-01-13 11:30:05 +00:00
39 changed files with 537 additions and 2825 deletions
Show Stats Expand all files Collapse all files

97
SYNTAX
View File

@ -1,97 +0,0 @@
MAKEFILE:
=========
<makefile> ::= '(' + "makefile" + { <makerule-clause> | <common-clause> }* ')'
<makerule-clause> ::= <file-clause>
| <all-clause>
| <md5-clause>
| <always-clause>
| <once-clause>
| <perms-clause>
| <md5-perms-clause>
| <paranoid-clause>
<common-clause> ::= '(' + "common" + <makerule-clause>* + ')'
<file-clause> ::= '(' + <fille-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action>+ + ')'
<all-clause> ::= '(' + <all-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action>+ + ')'
<md5-clause> ::= '(' + <md5-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action-spec> + ')'
<perms-clause> ::= '(' + <perms-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action-spec> + ')'
<md5-perms-clause> ::= '(' + <md5-perms-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action-spec> + ')'
<paranoid-clause> ::= '(' + <paranoid-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action-spec> + ')'
<always-clause> ::= '(' + <always-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action-spec> + ')'
<once-clause> ::= '(' + <once-clause-identifier>
+ <target-spec>
+ <prereq-spec>
+ <action-spec> + ')'
<file-clause-identifier> ::= "file"
| "makefile-rule"
| "is-out-of-date?"
<all-clause-identifier> ::= "all"
<md5-clause-identifier> ::= "md5"
<perms-clause-identifier> ::= "perms"
<md5-perms-clause-identifier> ::= "md5-perms"
<paranoid-clause-identifier> ::= "paranoid"
<always-clause-identifier> ::= "always"
<once-clause-identifier> ::= "once"
<common-target-spec> ::= <target-descr> | <target> | <target-list>
<target-descr> ::= <target-pattern> | <target-rx>
<target-pattern> ::= '"' + <prefix> + '%' + <suffix> + '"'
<prefix> ::= <letter-or-digit>*
<suffix> ::= <letter-or-digit>*
<target-rx> ::= '(' + "rx" + '(' + <submatch-connector>
+ <submatch-clause>{3} + ')' + ')'
<common-prereq-spec> ::= <prereq-descr>
<prereq-pattern> ::= '"' + <prefix> + '%' + <suffix> + '"'
<prereq-descr> ::= '(' + { <prereq-pattern> | <prereq> }* + ')'
<target-spec> ::= <target> | <target-list>
<target> ::= <filename>
<target-list> ::= '(' + <filename>+ + ')'
<prereq-spec> ::= <prereq-list>
<prereq> ::= <filename>
<prereq-list> ::= '(' + <prereq>* + ')'
<action> ::= <function-call> | <value>
<filename> ::= '"' + {<dir-separator> + { 'a'-'z''A'-'Z''0'-'9' ... }+ }+ + '"'

175
autovars.scm
View File

@ -1,175 +0,0 @@
(define fluid-$@ (make-preserved-thread-fluid (list)))
(define fluid-$< (make-preserved-thread-fluid (list)))
(define fluid-$? (make-preserved-thread-fluid (list)))
(define fluid-$^ (make-preserved-thread-fluid (list)))
(define fluid-$+ (make-preserved-thread-fluid (list)))
(define fluid-$* (make-preserved-thread-fluid (list)))
(define fluid-$=* (make-preserved-thread-fluid (list)))
(define fluid-$*= (make-preserved-thread-fluid (list)))
(define fluid-$=*= (make-preserved-thread-fluid (list)))
(define fluid-$@/ (make-preserved-thread-fluid (list)))
(define fluid-/$@ (make-preserved-thread-fluid (list)))
(define fluid-$=*=/ (make-preserved-thread-fluid (list)))
(define fluid-/$=*= (make-preserved-thread-fluid (list)))
(define fluid-$</ (make-preserved-thread-fluid (list)))
(define fluid-/$< (make-preserved-thread-fluid (list)))
(define fluid-$^/ (make-preserved-thread-fluid (list)))
(define fluid-/$^ (make-preserved-thread-fluid (list)))
(define fluid-$+/ (make-preserved-thread-fluid (list)))
(define fluid-/$+ (make-preserved-thread-fluid (list)))
(define fluid-$?/ (make-preserved-thread-fluid (list)))
(define fluid-/$? (make-preserved-thread-fluid (list)))
(define (bind-all-fluids target prereqs prereqs-results thunk)
(bind-fluids-gnu target prereqs prereqs-results thunk))
(define (bind-fluids-common target-name prefix match suffix thunk)
(let (($* match)
($*= suffix)
($=* prefix)
($=*= target-name))
;; $* : The stem with which an implicit rule matches.
(let-thread-fluids fluid-$* $*
fluid-$=* $=*
fluid-$*= $*=
fluid-$=*= $=*=
;; $(*D), $(*F) : directory part and file-within-directory
fluid-$=*=/ (file-name-directory $=*=)
fluid-/$=*= (file-name-nondirectory $=*=)
thunk)))
(define (bind-fluids-gnu target prereqs prereqs-results thunk)
(let (($@ target)
($< (cond
((and (list? prereqs) (not (null? prereqs))) (car prereqs))
((and (list? prereqs) (null? prereqs)) "")
(else prereqs)))
($? (cond
((not (list? prereqs))
(let ((newer-prereq (list)))
(if (car (rule-result-wants-build?
(car prereqs-results)))
(cons newer-prereq newer-prereq)
newer-prereq)))
((and (list? prereqs) (null? prereqs)) prereqs)
((list? prereqs)
(let for-prereqs ((newer-prereqs (list))
(current-prereq (car prereqs))
(todo-prereqs (cdr prereqs))
(current-result (car prereqs-results))
(todo-results (cdr prereqs-results)))
(let ((build? (if (is-rule-result? current-result)
(car (rule-result-wants-build?
current-result))
#f)))
(if build?
(if (not (null? todo-prereqs))
(for-prereqs (cons current-prereq
newer-prereqs)
(car todo-prereqs)
(cdr todo-prereqs)
(car todo-results)
(cdr todo-results))
newer-prereqs)
(if (not (null? todo-prereqs))
(for-prereqs newer-prereqs
(car todo-prereqs)
(cdr todo-prereqs)
(car todo-results)
(cdr todo-results))
newer-prereqs)))))
(else (error "no match in bind-fluids-gnu fluid-$?"))))
($^ (delete-duplicates! prereqs))
($+ prereqs))
(let-thread-fluids fluid-$@ $@ ;; $@ : file name of the target
;; $% : target member name, when target is an archive member.
;; fluid-$% target
;; $< : name of the first prerequisite
fluid-$< $<
;; $? : names of all prerequisites that are newer than target
fluid-$? $?
;; $^ : names of all the prerequisites without duplicates
;; $+ : names of all the prerequisites
fluid-$^ $^
fluid-$+ $+
;; we have no parens so we will use the following *scheme*:
;; e.g. for $@: $@/ denotes directory part of $@
;; while /$@ denotes file within directory of $@
;;
;; $(@D), $(@F) : directory part and file-within-directory
fluid-$@/ (file-name-directory $@)
fluid-/$@ (file-name-nondirectory $@)
;; $(%D), $(%F) : directory part and file-within-directory
; $%/ (file-name-directory fluid-$%)
; /$% (file-name-nondirectory fluid-$%)
;; $(<D), $(<F) : directory part and file-within-directory
fluid-$</ (file-name-directory $<)
fluid-/$< (file-name-nondirectory $<)
;; $(^D), $(^F) : directory part and file-within-directory
fluid-$^/ (map (lambda (d)
(file-name-directory d))
$^)
fluid-/$^ (map (lambda (f)
(file-name-nondirectory f))
$^)
;; $(+D), $(+F) : directory part and file-within-directory
fluid-$+/ (map (lambda (d)
(file-name-directory d))
$+)
fluid-/$+ (map (lambda (f)
(file-name-nondirectory f))
$+)
;; $(?D), $(?F) : directory part and the
;; file-within-directory part of $?.
fluid-$?/ (map (lambda (d)
(file-name-directory d))
$?)
fluid-/$? (map (lambda (f)
(file-name-nondirectory f))
$?)
thunk)))
(define ($@) (thread-fluid fluid-$@))
(define ($<) (thread-fluid fluid-$<))
(define ($?) (thread-fluid fluid-$?))
(define ($^) (thread-fluid fluid-$^))
(define ($+) (thread-fluid fluid-$+))
(define ($*) (thread-fluid fluid-$*))
(define ($=*) (thread-fluid fluid-$=*))
(define ($*=) (thread-fluid fluid-$*=))
(define ($=*=) (thread-fluid fluid-$=*=))
(define ($@/) (thread-fluid fluid-$@/))
(define (/$@) (thread-fluid fluid-/$@))
(define ($=*=/) (thread-fluid fluid-$=*=/))
(define (/$=*=) (thread-fluid fluid-/$=*=))
(define ($</) (thread-fluid fluid-$</))
(define (/$<) (thread-fluid fluid-/$<))
(define ($^/) (thread-fluid fluid-$^/))
(define (/$^) (thread-fluid fluid-/$^))
(define ($+/) (thread-fluid fluid-$+/))
(define (/$+) (thread-fluid fluid-/$+))
(define ($?/) (thread-fluid fluid-$?/))
(define (/$?) (thread-fluid fluid-/$?))
(define (bind-fluids-human target prereqs prereqs-results thunk)
(display "not yet implemented."))
;;; (define (bind-fluids-human target prereqs prereqs-results thunk)
;;; (lambda ()
;;; (bind-fluids-gnu target prereqs prereqs-results
;;; (lambda ()
;;; (let ((target-fname (make-preserved-thread-fluid $@))
;;; (prereqs-first (make-preserved-thread-fluid $<))
;;; (prereqs-to-build (make-preserved-thread-fluid $?))
;;; (prereqs-unique (make-preserved-thread-fluid $^))
;;; (prereqs (make-preserved-thread-fluid $+)))
;;; (thunk))))))

6
cml-pe.scm
View File

@ -23,7 +23,7 @@
(cml-sync-ch/receive-rv res-ch)))
(define (cml-fork/collecting fds sig-ch thunk)
(define (cml-fork-collecting fds sig-ch thunk)
(let* ((ch (cml-sync-ch/make-channel))
(res-ch (cml-sync-ch/make-channel))
(sig-rv (cml-sync-ch/receive-rv sig-ch))
@ -44,7 +44,7 @@
(let ((exitno (wait process)))
(cml-sync-ch/send ch (append (list exitno)
(map port->string read-ports)))))
(format #t "cml-fork/collecting: waiting (for ~a)\n" (proc:pid process)))
(format #t "cml-fork-collecting: waiting (for ~a)\n" (proc:pid process)))
(spawn
(lambda ()
@ -56,7 +56,7 @@
(loop)))))
(cml-rv/wrap proc-done-rv
(lambda (res) (cml-sync-ch/send res-ch res))))))
(format #t "cml-fork/collecting: signals (for ~a)\n" (proc:pid process)))
(format #t "cml-fork-collecting: signals (for ~a)\n" (proc:pid process)))
(for-each close-output-port write-ports)
(cml-sync-ch/receive-rv res-ch)))

425
collect-channels.scm
View File

@ -1,211 +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-record-type :cmd-msg
(make-cmd-msg cmd data)
is-cmd-msg?
(cmd cmd-msg-cmd)
(data cmd-msg-data))
(define (print-info tuid event name)
(format (current-error-port) ">>> ~a : ~a [~a]~%" tuid event name))
(define (no-modify msg) msg)
(define (always msg) #t)
(define (never msg) #f)
;;; (define (cond-sink pred modify in out name)
;;; (let ((tmp-ch (cml-sync-ch/make-channel)))
;;; (spawn
;;; (lambda ()
;;; (cml-sync-ch/send tmp-ch (thread-uid (current-thread)))
;;; (let cond-sink-lp ((msg (cml-sync-ch/receive in)))
;;; (if (pred msg)
;;; (cml-sync-ch/send out (modify msg)))
;;; (cond-sink-lp (cml-sync-ch/receive in))))
;;; name)
;;; (cml-sync-ch/receive tmp-ch)))
;;;
;;; (define (sink in out) (cond-sink never no-modify in out 'sink))
;;;
;;; (define (cond-tee pred modify in out alt name)
;;; (let ((tmp-ch (cml-sync-ch/make-channel)))
;;; (spawn
;;; (lambda ()
;;; (cml-sync-ch/send tmp-ch (thread-uid (current-thread)))
;;; (let cond-tee-lp ((msg (cml-sync-ch/receive in)))
;;; (if (pred msg)
;;; (cml-sync-ch/send out (modify msg))
;;; (cml-sync-ch/send alt msg))
;;; (cond-tee-lp (cml-sync-ch/receive in))))
;;; name)
;;; (cml-sync-ch/receive tmp-ch)))
;;;
;;; (define (tee in out) (cond-tee always no-modify in out #f 'tee))
;;;
;;; (define (tail-element from-head to-head from-sink to-sink in out)
;;; (let* ((id (tee from-sink to-head))
;;; (tag-msg (lambda (msg) (make-tagged-msg id msg)))
;;; (pred (lambda (tmsg) (eq? (tagged-msg-tag tmsg) id))))
;;; (cond-tee pred tagged-msg-stripped from-head out to-sink
;;; (string->symbol (string-append "tail-switch " (number->string id))))
;;; (cond-tee always tag-msg in to-head #f
;;; (string->symbol (string-append "tail-insert " (number->string id))))
;;; id))
(define (tail-element from-head to-head from-sink to-sink in out)
(let ((id-res-ch (cml-sync-ch/make-channel)))
(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* ((id (thread-uid (current-thread)))
(tag-msg (lambda (msg) (make-tagged-msg id msg)))
(pred (lambda (tmsg) (eq? (tagged-msg-tag tmsg) id))))
(cml-sync-ch/send id-res-ch id)
(let ((insert-msg (lambda (msg)
(cml-async-ch/send-async to-head (tag-msg msg))))
(insert-rv (cml-async-ch/receive-async-rv in))
(forward-msg (lambda (msg)
(cml-async-ch/send-async to-head msg)))
(forward-rv (cml-async-ch/receive-async-rv from-sink))
(deliver-msg (lambda (msg)
(if (pred msg)
(let ((stripped-msg (tagged-msg-stripped msg)))
(cml-async-ch/send-async out stripped-msg))
(cml-async-ch/send-async to-sink msg))))
(deliver-rv (cml-async-ch/receive-async-rv from-head)))
(let receive+send-lp ()
(cml-rv/select
(cml-rv/wrap insert-rv insert-msg)
(cml-rv/wrap forward-rv forward-msg)
(cml-rv/wrap deliver-rv deliver-msg))
(receive+send-lp))))))
(cml-sync-ch/receive id-res-ch)))
(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-enumerated-type collect-cmd :collect-cmd
is-collect-cmd?
the-collect-cmds
collect-cmd-name
collect-cmd-index
(make-link))
(define (head-element modify cmd-in cmd-out head-in head-out name)
(let ((id-res-ch (cml-sync-ch/make-channel))
(pred (lambda (msg)
(cond
((and (is-cmd-msg? msg)
(is-collect-cmd? (cmd-msg-cmd msg))
(eq? (cmd-msg-cmd msg) (collect-cmd make-link))) #f)
((is-tagged-msg? msg) #t)
(else (error "head-element: wrong type" msg))))))
(define (send&collect/tee2 from-server to-sink from-sink to-server in out)
(let ((tmp-ch (cml-sync-ch/make-channel)))
(spawn
(lambda ()
(cml-sync-ch/send id-res-ch (thread-uid (current-thread)))
; (sink head-out head-in)
(let head-element-lp ((from-tail head-in)
(to-tail head-out))
(let* ((forward-msg (lambda (ch msg)
(cml-async-ch/send-async ch (modify msg))
(cons from-tail to-tail)))
(new-tail-el (lambda (msg)
(let* ((chs (cmd-msg-data msg))
(new-from-tail
(cml-async-ch/make-async-channel))
(new-to-tail
(cml-async-ch/make-async-channel))
(link-in (list-ref chs 0))
(link-out (list-ref chs 1))
(tmp-ch (list-ref chs 2))
(id (tail-element new-to-tail new-from-tail
from-tail to-tail
link-in link-out)))
(cml-async-ch/send-async tmp-ch id)
(cons new-from-tail new-to-tail))))
(chs (cml-rv/select
(cml-rv/wrap (cml-async-ch/receive-async-rv cmd-in)
(lambda (msg)
(if (pred msg)
(forward-msg to-tail msg)
(new-tail-el msg))))
(cml-rv/wrap (cml-async-ch/receive-async-rv from-tail)
(lambda (msg) (forward-msg cmd-out msg))))))
(head-element-lp (car chs) (cdr chs)))))
name)
(cml-sync-ch/receive id-res-ch)))
(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-record-type :collect&reply-channel
(collect&reply/really-make-channel cmd-in cmd-out)
is-collect&reply-channel?
(cmd-in collect&reply-channel-cmd-in)
(cmd-out collect&reply-channel-cmd-out))
(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-async-ch/make-async-channel))
(cmd-out (cml-async-ch/make-async-channel))
(head-in (cml-async-ch/make-async-channel))
(head-out (cml-async-ch/make-async-channel)))
(head-element no-modify cmd-in cmd-out head-in head-out 'collect&reply)
(collect&reply/really-make-channel cmd-in cmd-out)))
(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-async-ch/make-async-channel))
(from<--to (cml-async-ch/make-async-channel))
(to-tmp-ch (cml-async-ch/make-async-channel))
(from-tmp-ch (cml-async-ch/make-async-channel))
(chs-for-to (make-cmd-msg (collect-cmd make-link)
(list from-->to from<--to to-tmp-ch)))
(chs-for-from (make-cmd-msg (collect-cmd make-link)
(list from<--to from-->to from-tmp-ch))))
(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))
(collect&reply/send to chs-for-to)
(send&collect/send from chs-for-from)
(cml-rv/select
(cml-rv/wrap (cml-async-ch/receive-async-rv from-tmp-ch)
(lambda (id-from)
(cons id-from
(cml-rv/sync
(cml-async-ch/receive-async-rv to-tmp-ch)))))
(cml-rv/wrap (cml-async-ch/receive-async-rv to-tmp-ch)
(lambda (id-to)
(cons (cml-rv/sync (cml-async-ch/receive-async-rv
from-tmp-ch))
id-to)))))
(else (error "make-link: wrong type" from to)))))
(define-record-type :send&collect-channel
(send&collect/really-make-channel cmd-in cmd-out)
is-send&collect-channel?
(cmd-in send&collect-channel-cmd-in)
(cmd-out send&collect-channel-cmd-out))
(define (send&collect/make-channel)
(let ((cmd-in (cml-async-ch/make-async-channel))
(cmd-out (cml-async-ch/make-async-channel))
(head-in (cml-async-ch/make-async-channel))
(head-out (cml-async-ch/make-async-channel)))
(head-element no-modify cmd-in cmd-out head-in head-out 'send&collect)
(send&collect/really-make-channel cmd-in cmd-out)))
(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-rv/sync
(cml-async-ch/receive-async-rv (collect&reply-channel-cmd-out ch))))
(cml-sync-ch/receive (collect&reply-channel-cmd-out ch)))
(define (collect&reply/receive-rv ch)
(cml-async-ch/receive-async-rv (collect&reply-channel-cmd-out ch)))
(cml-sync-ch/receive-rv (collect&reply-channel-cmd-out ch)))
(define (collect&reply/send ch msg)
(cml-async-ch/send-async (collect&reply-channel-cmd-in 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-async-ch/send-async (send&collect-channel-cmd-in 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-rv/sync
(cml-async-ch/receive-async-rv (send&collect-channel-cmd-out ch))))
(cml-sync-ch/receive (send&collect-channel-cmd-out ch)))
(define (send&collect/receive-rv ch)
(cml-async-ch/receive-async-rv (send&collect-channel-cmd-out ch)))
(cml-sync-ch/receive-rv (send&collect-channel-cmd-out ch)))

50
common-rules.scm
View File

@ -1,50 +0,0 @@
(define-record-type :common-rules
(make-common-rules ls)
is-common-rules?
(ls common-rules-ls))
(define (make-empty-common-rules)
(make-common-rules (list match-all-func)))
(define (error-if-nonexistant target)
(error "file (assumed leaf) doesn't exist:" target))
(define (match-all-func will-be-target)
(make-rule-cand will-be-target
(list)
(lambda args
(let ((target (car args))
(init-state (last args)))
(cons (file-not-exists? will-be-target) init-state)))
(lambda args
(let ((target (car args))
(cooked-state (last args)))
(error-if-nonexistant target)))))
(define (add-common-rules common-rules func)
(make-common-rules (cons func (common-rules-ls common-rules))))
(define (search-match-in-common-rules common-rules target)
(let ((common-rs (common-rules-ls common-rules)))
(if (null? common-rs)
#f
(let next-common-rule ((current (car common-rs))
(todo (cdr common-rs)))
(let ((maybe-target (current target)))
(if maybe-target
maybe-target
(if (null? todo)
#f
(next-common-rule (car todo) (cdr todo)))))))))
(define (common-rcs->common-rules common-rcs)
(let ((empty-rules (make-empty-common-rules)))
(if (null? common-rcs)
empty-rules
(let for-each-rc ((rc (car common-rcs))
(todo (cdr common-rcs))
(done empty-rules))
(let ((current (add-common-rules done rc)))
(if (null? todo)
current
(for-each-rc (car todo) (cdr todo) current)))))))

236
dfs.scm
View File

@ -1,236 +0,0 @@
;;;
;;; merge(?) sort for general purpose:
;;; ==================================
;;;
;;; (sort predicate list-to-be-sorted to-sort-in-list) ---> sorted-list
;;;
;;; where
;;;
;;; predicate : (lambda (a b) ...) with a x b ---> {#t, #f}
;;; e.g. (lambda (a b) (> a b))
;;; list-to-be-sorted : e.g. '(4 2 5 1 3)
;;; to-sort-in-list : e.g. '(6)
;;;
;;; will produce the result '(6 5 4 3 2 1).
;;;
(define (sort pred todo done)
(if (null? todo)
done
(sort pred (cdr todo) (insert pred (car todo) done))))
(define (insert pred item ls)
(if (or (null? ls) (pred item (car ls)))
(cons item ls)
(cons (car ls) (insert pred item (cdr ls)))))
(define-enumerated-type color :color
is-color?
the-colors
color-name
color-index
(white grey black))
;;;
;;; DFS:
;;; ====
;;;
;;; (make-dfs node-name adjacencies ignored-data) ---> #{:dfs}
;;;
;;; node-name : "this is a node name"
;;; adjacencies : (list "another node name" "no node name")
;;; ignored-data : "anything you need in each node, eg. a long list..."
;;;
;;; (dfs->list node) ---> '(node-name adjacencies ignored-data)
;;;
;;; node : #{:dfs}
;;;
;;; (dfs-name node) ---> node-name
;;; (dfs-adjacencies node) ---> adjacencies
;;; (dfs-color node) ---> #{:color}
;;; (dfs-ftime node) ---> finishing-time
;;; (dfs-ignored node) ---> ignored-data
;;;
(define-record-type :dfs
(really-make-dfs name adjacencies color ftime ignored)
is-dfs?
(name dfs-name)
(adjacencies dfs-adjacencies)
;; color (white by default)
(color dfs-color)
;; finishing-time
(ftime dfs-ftime)
;; put in there what you like
(ignored dfs-ignored))
(define (make-dfs node-name adjacencies ignored-data)
(really-make-dfs node-name adjacencies (color white) 0 ignored-data))
(define (dfs->list dfs-node)
(list (dfs-name dfs-node) (dfs-adjacencies dfs-node) (dfs-ignored dfs-node)))
(define (resolve-adj pred adj dag)
(find (lambda (candidate)
(pred (dfs-name candidate) adj))
dag))
(define (replace-node dag old new)
(let ((new-dag (delete old dag)))
(cons new new-dag)))
(define (paint-node node color)
(let ((name (dfs-name node))
(adjs (dfs-adjacencies node))
(time (dfs-ftime node))
(ignored (dfs-ignored node)))
(really-make-dfs name adjs color time ignored)))
(define (set-ftime node ftime)
(let ((name (dfs-name node))
(adjs (dfs-adjacencies node))
(color (dfs-color node))
(ignored (dfs-ignored node)))
(really-make-dfs name adjs color ftime ignored)))
;;;
;;; DEPTH FIRST SEARCH:
;;; ===================
;;;
;;; (dfs dag) ---> sorted-dag
;;; (dfs dag pred auto-leafs? create-leaf) ---> sorted-dag
;;;
;;; where
;;;
;;; dag : '(#{:dfs} ...) ; representation of a given
;;; directed acyclic graph)
;;; pred : (pred adj-id node-id) ---> #t (if adj-identifier
;;; and node-identifier are equal) or #f
;;;
;;; auto-leafs? : #t (by default) or #f
;;; if auto-leafs? is set to #f then it is an error
;;; that an adjacency is unresolveable in the list of
;;; all node-names. if auto-leafs? is enabled then
;;; every adjacency which is unresolveable in the list
;;; of all node-names is assumed to point to a leaf.
;;; this leaf is then created automatically by
;;; executing the function create-leaf.
;;;
;;; create-leaf : (create-leaf unresolved-adjacency-identifier) ---> #{:dfs}
;;; create-leaf is a function which is called with the
;;; unresolved adjacency identifier. By default, this
;;; argument is function returning a leaf named with
;;; the unresolved adjacency identifier, with no
;;; adjacencies, and ignored-data set to #f. This
;;; leaf, created by create-leaf, doesn't really have
;;; to be a leaf; it can be a node as well. Maybe this
;;; introduces new cyclic dependency problems; not sure.
;;;
;;; sorted-dag : the sorted dag
;;;
(define (dfs dag . maybe-args)
(let-optionals maybe-args
((pred string=?)
(auto-leafs? #t)
(create-leaf (lambda (unresolved-adj)
(make-dfs unresolved-adj '() #f))))
(let ((ftime<? (lambda (cur pos)
(< (dfs-ftime cur) (dfs-ftime pos)))))
(if (not (null? dag))
(sort ftime<?
(visit-all-nodes dag pred auto-leafs? create-leaf)
(list))
dag))))
(define (visit-all-nodes start-dag pred auto-leafs? create-leaf)
(let for-each-node ((node (car start-dag))
(todo (cdr start-dag))
(dag start-dag)
(time 0))
(cond
((eq? (dfs-color node) (color white))
(let* ((result (visit dag node time pred auto-leafs? create-leaf))
(new-dag (car result))
(new-time (cdr result)))
(if (not (null? todo))
(for-each-node (car todo) (cdr todo) new-dag new-time)
new-dag)))
((eq? (dfs-color node) (color black))
(if (not (null? todo))
(for-each-node (car todo) (cdr todo) dag time)
dag))
(else (error "visit-all-nodes: no match")))))
(define (finish-visit dag node time)
(let* ((new-time (+ 1 time))
(done-node (set-ftime (paint-node node (color black))
new-time))
(done-dag (replace-node dag node done-node)))
(cons done-dag new-time)))
(define (visit old-dag old-node time pred auto-leafs? create-leaf)
(let* ((node (paint-node old-node (color grey)))
(adjs (dfs-adjacencies node))
(dag (replace-node old-dag old-node node)))
(if (not (null? adjs))
(visit-all-adjs dag node adjs time pred auto-leafs? create-leaf)
(finish-visit dag node time))))
(define (visit-all-adjs dag node adjs time pred auto-leafs? create-leaf)
(let for-each-adj ((cur-adj (car adjs))
(todo (cdr adjs))
(cur-dag dag)
(cur-time time))
(let* ((res (follow-adj cur-dag node cur-adj cur-time
pred auto-leafs? create-leaf))
(new-dag (car res))
(new-time (cdr res)))
(if (not (null? todo))
(for-each-adj (car todo) (cdr todo) new-dag new-time)
(finish-visit new-dag node new-time)))))
(define (follow-adj dag node adj time pred auto-leafs? create-leaf)
(let ((maybe-node (resolve-adj pred adj dag)))
(if maybe-node
(cond
((eq? (dfs-color maybe-node) (color white))
(visit dag maybe-node time pred auto-leafs? create-leaf))
((eq? (dfs-color maybe-node) (color grey))
(error "follow-adj, cycle detected: " (dfs-name node)))
((eq? (dfs-color maybe-node) (color black))
(cons dag time))
(else (error "follow-adj: no match")))
(if auto-leafs?
(let* ((leaf (create-leaf adj))
(new-dag (cons leaf dag)))
(visit new-dag leaf time pred auto-leafs? create-leaf))
(error "follow-adj: unresolveable adjacency: " adj)))))
(define (dfs-dag-show dag . maybe-arg)
(let-optionals maybe-arg ((node (make-dfs "show dag" '() #f)))
(newline) (newline) (newline) (newline)
(display "************************************************************\n")
(display (dfs-name node)) (newline)
(display "************************************************************\n")
(let ((dfs-node-show (lambda (node)
(newline)
(display "~dfs-name: ")
(display (dfs-name node))
(newline)
(display "~dfs-adjacencies: ")
(display (dfs-adjacencies node))
(newline)
(display "~dfs-color: ")
(display (dfs-color node))
(newline)
(display "~dfs-ftime: ")
(display (dfs-ftime node))
(newline)
(display "~dfs-ignored: ")
(display (dfs-ignored node))
(newline))))
(if (not (null? dag))
(let visit-each-node ((current-node (car dag))
(nodes-to-do (cdr dag)))
(dfs-node-show current-node)
(if (not (null? nodes-to-do))
(visit-each-node (car nodes-to-do) (cdr nodes-to-do))
(newline)))))))

31
examples/README
View File

@ -1,31 +0,0 @@
Starting make:
==============
In XEmacs open a new buffer to edit this makefile-c.scm. Make sure you
had no active scheme-buffer. This will have the effect that your
current working directory is the one with makefile-c.scm in it. Now
open a new scheme-buffer with 'M-x run-scheme'. You should have passed
(at least) the following arguments to scsh:
'scsh -lel cml/load.scm -lel concurrency/load.scm'
Now load the packages.scm file into package config:
> ,config ,load ../packages.scm
Open the structures macros and make in package user:
> ,open macros make
Load makefile-c.scm:
> ,load makefile-c.scm
Start make:
> (make rule-set (list "test"))
This should start a build all, install, and test installation process.
By default, the installation directory will be ../../image.
Have fun.

3
examples/checksums.md5
View File

@ -1,3 +0,0 @@
71537751982895759163390057694999171418 config.h
14291919577004468625754235508931697268 mymath.c
277010555671960749526965727376092322885 manual.tex

3
examples/config.h
View File

@ -1,3 +0,0 @@
#ifndef MY_DELTA_MAX
#define MY_DELTA_MAX 0.00000000000001
#endif

44
examples/main.c
View File

@ -1,44 +0,0 @@
#include "wildio.h"
#include "mymath.h"
#include <dlfcn.h>
#include <stdio.h>
double magic_number = 0.0;
int main(int argc, char** argv) {
void *libwildio;
int (*show_a_double_call)(double);
double (*checkargs_call)(int,char**);
void *libmymath;
double (*sqrt_call)(double), result;
dlerror();
if (libwildio=dlopen("libwildio.so.1",RTLD_LAZY))
{
checkargs_call = dlsym(libwildio,"checkargs");
show_a_double_call = dlsym(libwildio,"show_a_double");
/* magic_number will be set by checkargs */
magic_number = (*checkargs_call)(argc,argv);
if (libmymath=dlopen("libmymath.so.1",RTLD_LAZY)) {
sqrt_call = dlsym(libmymath,"sqrt");
magic_number = (*sqrt_call)(magic_number);
result = (*show_a_double_call)(magic_number);
dlclose(libmymath);
dlclose(libwildio);
return result;
}
}
/* last exit */
exit(1);
}

200
examples/makefile-c.scm
View File

@ -1,200 +0,0 @@
(define image-dir "../../image")
(define prefix (string-append image-dir "/" "usr"))
(define my-lib-dir (string-append prefix "/" "lib"))
(define my-bin-dir (string-append prefix "/" "bin"))
(define my-share-dir (string-append prefix "/" "share"))
(define my-doc-dir (string-append my-share-dir "/" "doc"))
(define my-install-doc-dir (string-append my-doc-dir "/" "show-sqrt-1.0"))
(define clean-files
(list "wildio.o" "mymath.o"
"libwildio.so.1.0" "libmymath.so.1.0"
"libwildio.so.1" "libmymath.so.1"
"libwildio.so" "libmymath.so"
"show-sqrt"
"manual.dvi" "manual.pdf" "manual.log" "manual.aux"))
(define file-set
(makefile
;;
;; create a configfile
;;
(md5 "config.h"
()
(let ((outport (open-output-file ($@))))
(with-current-output-port outport
(display "#ifndef MY_DELTA_MAX\n")
(display "#define MY_DELTA_MAX 0.000000001\n")
(display "#endif\n")
(close-output-port outport))))
;;
;; build libmymath.*
;;
(file "mymath.o"
("mymath.c" "config.h")
(run (gcc -fPIC -c ,($<))))
(file "libmymath.so.1.0"
("mymath.o")
(run (gcc -shared ,"-Wl,-soname,libmymath.so.1" -o ,($@) ,($<))))
;;
;; build wildio.*
;;
(file "wildio.o"
("wildio.c")
(run (gcc -fPIC -c ,($<))))
(file "libwildio.so.1.0"
("wildio.o")
(run (gcc -shared "-Wl,-soname,libwildio.so.1" -o ,($@) ,($<))))
;;
;; build the program
;;
(md5 "show-sqrt"
("main.c" "libmymath.so.1" "libwildio.so.1" "wildio.h" "mymath.h")
(run (gcc -L ,(cwd) -L ,my-lib-dir -rdynamic
-o ,($@) ,($<) ,"libwildio.so.1" ,"libmymath.so.1" -ldl)))
;;
;; install libs
;;
(file "libmymath.so.1"
("libmymath.so.1.0")
(create-symlink ($<) ($@)))
(file "libmymath.so"
("libmymath.so.1")
(create-symlink ($<) ($@)))
(file "libwildio.so.1"
("libwildio.so.1.0")
(create-symlink ($<) ($@)))
(file "libwildio.so"
("libwildio.so.1")
(create-symlink ($<) ($@)))
(file (string-append my-lib-dir "/" "libmymath.so.1")
((string-append my-lib-dir "/" "libmymath.so.1.0"))
(with-cwd ($@/) (create-symlink (/$<) (/$@))))
(file (string-append my-lib-dir "/" "libmymath.so")
((string-append my-lib-dir "/" "libmymath.so.1"))
(with-cwd ($@/) (create-symlink (/$<) (/$@))))
(file (string-append my-lib-dir "/" "libwildio.so.1")
((string-append my-lib-dir "/" "libwildio.so.1.0"))
(with-cwd ($@/) (create-symlink (/$<) (/$@))))
(file (string-append my-lib-dir "/" "libwildio.so")
((string-append my-lib-dir "/" "libwildio.so.1"))
(with-cwd ($@/) (create-symlink (/$<) (/$@))))
(file (string-append my-lib-dir "/" "libwildio.so.1.0")
("libwildio.so.1.0" my-lib-dir)
(run (cp ,($<) ,($@))))
(file (string-append my-lib-dir "/" "libmymath.so.1.0")
("libmymath.so.1.0" my-lib-dir)
(run (cp ,($<) ,($@))))
;;
;; install the program
;;
(file (string-append my-bin-dir "/" "show-sqrt")
("show-sqrt" my-bin-dir)
(run (cp ,($<) ,($@))))
;;
;; build the manual
;;
(md5 "manual.dvi"
("manual.tex")
(run (latex ,($<))))
(file "manual.pdf"
("manual.dvi")
(run (dvipdfm -o ,($@) ,($<))))
;;
;; install the manual
;;
(file (string-append my-install-doc-dir "/" "manual.pdf")
("manual.pdf" my-install-doc-dir)
(run (cp ,($<) ,($@))))
;;
;; install all
;;
(always "install"
((string-append my-lib-dir "/" "libmymath.so.1.0")
(string-append my-lib-dir "/" "libwildio.so.1.0")
(string-append my-lib-dir "/" "libmymath.so.1")
(string-append my-lib-dir "/" "libwildio.so.1")
(string-append my-lib-dir "/" "libmymath.so")
(string-append my-lib-dir "/" "libwildio.so")
(string-append my-bin-dir "/" "show-sqrt")
(string-append my-install-doc-dir "/" "manual.pdf"))
(display "install done.\n"))
;;
;; clean files
;;
(always "clean"
()
(for-each (lambda (f)
(delete-filesys-object (expand-file-name f (cwd))))
clean-files))
;;
;; clean files
;;
(always "mrproper"
("clean")
(for-each (lambda (f)
(delete-filesys-object (expand-file-name f (cwd))))
(list "checksums.md5")))
;;
;; uninstall all
;;
(always "uninstall"
("clean")
(begin
(display "uninstall: \n")
(for-each (lambda (f)
(display "remove: ") (display f) (newline)
(delete-filesys-object f))
(list (string-append my-lib-dir "/" "libmymath.so.1.0")
(string-append my-lib-dir "/" "libwildio.so.1.0")
(string-append my-lib-dir "/" "libmymath.so.1")
(string-append my-lib-dir "/" "libwildio.so.1")
(string-append my-lib-dir "/" "libmymath.so")
(string-append my-lib-dir "/" "libwildio.so")
(string-append my-bin-dir "/" "show-sqrt")
(string-append my-install-doc-dir "/" "manual.pdf")
my-install-doc-dir
my-doc-dir
my-share-dir
my-lib-dir
my-bin-dir
prefix
image-dir))
(display "uninstall done.\n")))
;;
;; install dirs
;;
(once image-dir
()
(create-directory image-dir))
(once prefix
(image-dir)
(create-directory prefix))
(once my-lib-dir
(prefix)
(create-directory my-lib-dir))
(once my-bin-dir
(prefix)
(create-directory my-bin-dir))
(once my-share-dir
(prefix)
(create-directory my-share-dir))
(once my-doc-dir
(my-share-dir)
(create-directory my-doc-dir))
(once my-install-doc-dir
(my-doc-dir)
(create-directory my-install-doc-dir))
;;
;; a small test
;;
(always "test"
("install")
(let ((proggy (expand-file-name "show-sqrt" my-bin-dir)))
(display "testing ") (display proggy) (newline)
(setenv "LD_LIBRARY_PATH" my-lib-dir)
(display "# sqrt 2.0:\n")
(run (,proggy ,"2.0"))
(display "# sqrt 5.0:\n")
(run (,proggy ,"5.0"))
(display "ok.\n")))))

81
examples/makefile-common-rules.scm
View File

@ -1,81 +0,0 @@
(define clean-files
(list "wildio.o" "mymath.o"
"libwildio.so.1.0" "libmymath.so.1.0"
"libwildio.so.1" "libmymath.so.1"
"libwildio.so" "libmymath.so"
"show-sqrt"
"manual.dvi" "manual.pdf" "manual.ps" "manual.log" "manual.aux"
"a-manual.dvi" "a-manual.pdf" "a-manual.ps" "a-manual.log" "a-manual.aux"
"b-manual.dvi" "b-manual.pdf" "b-manual.ps" "b-manual.log" "b-manual.aux"
"c-manual.dvi" "c-manual.pdf" "c-manual.ps" "c-manual.log" "c-manual.aux"
"d-manual.dvi" "d-manual.pdf" "d-manual.ps" "d-manual.log" "d-manual.aux"
"e-manual.dvi" "e-manual.pdf" "e-manual.ps" "e-manual.log" "e-manual.aux"
"f-manual.dvi" "f-manual.pdf" "f-manual.ps" "f-manual.log" "f-manual.aux"
"g-manual.dvi" "g-manual.pdf" "g-manual.ps" "g-manual.log" "g-manual.aux"
"h-manual.dvi" "h-manual.pdf" "h-manual.ps" "h-manual.log" "h-manual.aux"
"i-manual.dvi" "i-manual.pdf" "i-manual.ps" "i-manual.log" "i-manual.aux"
"j-manual.dvi" "j-manual.pdf" "j-manual.ps" "j-manual.log" "j-manual.aux"
"another-manual.dvi" "another-manual.pdf" "another-manual.ps"
"another-manual.log" "another-manual.aux"))
;(string-append ($*) ".c") (string-append ($*) ".h")
(define file-set
(makefile
(common-rx
(file (rx (: (submatch "") (submatch (+ any)) (submatch ".o")))
("%.c" "%.h")
(run (gcc -fPIC -c ,(string-append ($*) ".c")))))
(common-%
(file "lib%.so.1.0"
("%.o")
(run
(gcc -shared ,(string-append "-Wl,-soname," ($=*) ".so.1")
-o ,($@) ,($<))))
(file "lib%.so.1"
("lib%.so.1.0")
(create-symlink ($<) ($@)))
(file "lib%.so"
("lib%.so.1")
(create-symlink ($<) ($@)))
(file "%.dvi"
("%.tex")
(run (latex ,($<))))
(file "%.pdf"
("%.dvi")
(run (dvipdfm -o ,($@) ,($<))))
(file "%.ps"
("%.dvi")
(run (dvips -o ,($@) ,($<)))))
;;
;; build the program
;;
(file "show-sqrt"
("main.c" "libmymath.so.1" "libwildio.so.1" "wildio.h" "mymath.h")
(run (gcc -L ,(cwd) -rdynamic
-o ,($@) ,($<) ,"libwildio.so.1" ,"libmymath.so.1" -ldl)))
;;
;; fake install
;;
(always "install"
("show-sqrt" "manual.ps" "manual.pdf"
"another-manual.pdf" "another-manual.ps"
"a-manual.dvi" "a-manual.pdf" "a-manual.ps"
"b-manual.dvi" "b-manual.pdf" "b-manual.ps"
"c-manual.dvi" "c-manual.pdf" "c-manual.ps"
"d-manual.dvi" "d-manual.pdf" "d-manual.ps"
"e-manual.dvi" "e-manual.pdf" "e-manual.ps"
"f-manual.dvi" "f-manual.pdf" "f-manual.ps"
"g-manual.dvi" "g-manual.pdf" "g-manual.ps"
"h-manual.dvi" "h-manual.pdf" "h-manual.ps"
"i-manual.dvi" "i-manual.pdf" "i-manual.ps"
"j-manual.dvi" "j-manual.pdf" "j-manual.ps")
(for-each (lambda (f) (display ">>> ") (display f) (newline)) ($+))
(display "install done.\n"))
;;
;; clean files
;;
(always "clean"
()
(for-each (lambda (f)
(delete-filesys-object (expand-file-name f (cwd))))
clean-files))))

40
examples/makefile-tex.scm
View File

@ -1,40 +0,0 @@
(define clean-files
(list "manual.dvi" "manual.pdf" "manual.ps" "manual.log" "manual.aux"
"another-manual.dvi" "another-manual.ps" "another-manual.pdf"))
(define file-set
(makefile
(once "manual.dvi"
("manual.tex")
(run (latex ,($<))))
(file "manual.pdf"
("manual.dvi")
(run (dvipdfm -o ,($@) ,($<))))
(file "manual.ps"
("manual.dvi")
(run (dvips -o ,($@) ,($<))))
(file "another-manual.dvi"
("manual.dvi")
(create-symlink ($<) ($@)))
(file "another-manual.ps"
("another-manual.dvi")
(run (dvips -o ,($@) ,($<))))
(file "another-manual.pdf"
("another-manual.dvi")
(run (dvipdfm -o ,($@) ,($<))))
;;
;; fake install
;;
(always "install"
("manual.ps" "manual.dvi" "manual.pdf"
"another-manual.dvi" "another-manual.ps" "another-manual.pdf")
(for-each (lambda (f) (display ">>> ") (display f) (newline)) ($+))
(display "install done.\n"))
;;
;; clean files
;;
(always "clean"
()
(for-each (lambda (f)
(delete-filesys-object (expand-file-name f (cwd))))
clean-files))))

19
examples/manual.tex
View File

@ -1,19 +0,0 @@
\documentclass[a4paper]{report}
\usepackage[dvipdfm,hyperindex,hypertex,
pdftitle={show-sqrt manual, release 1.0},
pdfauthor={Johannes Brügmann}
colorlinks=true,linkcolor=blue,pagecolor=blue,urlcolor=blue,
pdfstartview=FitW,pdfview=FitW]{hyperref}
\usepackage{charter}
\author{Real A. Name}
\title{show-sqrt rel. 1.0 manual}
\begin{document}
\maketitle
This is the show-sqrt release 1.0 manual.
show-sqrt comes with a single feature: It calculates the square root
of a passed as an argument given positive double value and prints the
result on screen (stdout).
Have fun.
\end{document}

28
examples/mymath.c
View File

@ -1,28 +0,0 @@
#include "config.h"
double positive (double x) {
if (x > 0.0)
return x;
else
return 0.0 - x;
}
double sqrt (double a) {
double x_old = 1.0, x_new = 0.5;
if (a > 0.0) {
do {
x_old = x_new;
x_new = ((a / x_old) + x_old) / 2.0;
} while (positive(x_old - x_new) > MY_DELTA_MAX);
return x_new;
} else exit(1);
}

1
examples/mymath.h
View File

@ -1 +0,0 @@
double sqrt (double a);

86
examples/test-embed.scm
View File

@ -1,86 +0,0 @@
(define at-uni? #t)
(define pred string=?)
(define obj-rules
(list
(file-rx (rx (: (submatch "") (submatch (+ any)) (submatch ".o")))
(list "%.c" "%.h")
(lambda () (run (gcc -fPIC -c ,(string-append ($*) ".c")))))))
(define lib-rules
(list
(md5-% "lib%.so.1.0"
(list "%.o")
(lambda () (run (gcc -shared
,(string-append "-Wl,-soname," ($=*) ".so.1")
-o ,($@) ,($<)))))
(file-% "lib%.so.1"
(list "lib%.so.1.0")
(lambda () (create-symlink ($<) ($@))))
(file-% "lib%.so"
(list "lib%.so.1")
(lambda () (create-symlink ($<) ($@))))))
(define tex-rules
(list
(file-% "%.dvi"
(list "%.tex")
(lambda () (run (latex ,($<)))))
(file-% "%.pdf"
(list "%.dvi")
(lambda () (run (dvipdfm -o ,($@) ,($<)))))
(file-% "%.ps"
(list "%.dvi")
(lambda () (run (dvips -o ,($@) ,($<)))))))
(define proggy
(if at-uni?
(file->rc "show-sqrt"
(list "main.c" "libmymath.so.1"
"libwildio.so.1" "wildio.h" "mymath.h")
(lambda () (run (gcc -L ,(cwd) ,(ldflags) -rdynamic
-o ,($@) ,($<)
,"libwildio.so.1" ,"libmymath.so.1" -lc))))
(file->rc "show-sqrt"
(list "main.c" "libmymath.so.1"
"libwildio.so.1" "wildio.h" "mymath.h")
(lambda () (run (gcc -L ,(cwd) -rdynamic -o ,($@) ,($<)
,"libwildio.so.1" ,"libmymath.so.1" -ldl))))))
(define manuals
(let* ((prefixes (list "a" "b" "c" "d")))
(append
(map (lambda (pre)
(string-append pre "-manual.dvi"))
prefixes)
(map (lambda (pre)
(string-append pre "-manual.ps"))
prefixes)
(map (lambda (pre)
(string-append pre "-manual.pdf"))
prefixes))))
(define install
(always->rc "install"
(append (list "show-sqrt") manuals)
(lambda ()
(for-each (lambda (f) (display ">>> ") (display f) (newline)) ($+))
(display "install done.\n"))))
(define clean
(always->rc "clean"
(list)
(lambda ()
(for-each (lambda (f)
(delete-filesys-object (expand-file-name f (cwd))))
(append manuals (list "show-sqrt"))))))
(define rcs (list proggy install clean))
(define commons (append obj-rules lib-rules tex-rules))
(define rules (rcs+commons->rules pred rcs commons))
;; (define rule-set (rules->rule-set rules))
(define done (make rules (list "clean" "install")))

28
examples/wildio.c
View File

@ -1,28 +0,0 @@
#include <stdio.h>
#include <errno.h>
int show_a_double (double x) {
printf(">> double: %09.15f\n", x);
}
int usage(char *progname) {
char *str;
printf("usage: %s <double-value>\n", progname);
exit(ENOTSUP);
}
int checkargs(int argc, char *argv[]) {
double darg = 0.0;
if (argc != 2) usage((char *const) argv[0]);
else darg = atof(argv[1]);
return darg;
}

2
examples/wildio.h
View File

@ -1,2 +0,0 @@
int show_a_double (double x);
int checkargs(int argc, char *argv[]);

110
gcc-m.scm
View File

@ -1,110 +0,0 @@
#!/usr/bin/scsh -s
!#
(define targets-prereqs
; f : which file to scan
; i-dirs : the directories where to look for include files
(lambda (f i-dirs)
(let ; calling gcc-cmd returns
; all dependencies in one entire string
((raw-deps (lambda (file dirs)
; full command string
(let ((gcc-cmd (lambda (my-file ds)
; build the include args for gcc e.g.
; ("-I." "-I.." "-I/usr/include")
(let ((i-args (lambda (d)
(let
((add-prefix
(lambda (p s)
(map
string-append
(circular-list p)
s))))
(add-prefix "-I" d)))))
(append
(list "gcc" "-M")
(i-args ds)
(list my-file))))))
(run/string ,(gcc-cmd file dirs)))))
; cook-deps returns a list like ("target:" "filename" "otherfile" ...)
(cook-deps (lambda (rdeps)
(let
; merge all \ -separated lines
; into one entire line
((unbreak-lines (lambda (str)
(regexp-substitute/global
#f
(rx (: (* white)
#\\
#\newline
(* white)))
str
'pre " " 'post)))
; break a string into tokens
; "a space delimeted string" ->
; ("a" "space" "delimited" "string")
(extract-f-l (lambda (s)
(string-tokenize s char-set:graphic))))
(extract-f-l (unbreak-lines rdeps)))))
; splits a list of strings into a target and its prerequisites
; by searching for an element with a colon as the last character
; returns a pair list and needs the list of dependencies
(t-p-pair (lambda (deps-l)
(let
; deletes the last character colon...
((delete-colon (lambda (target)
(regexp-substitute/global
#f
(rx (: #\: eos))
target
'pre 'post)))
; as list-index returns the element no
; starting at 0, last-target-element
; increases this index by 1
(last-target-element
(lambda (str-l)
; tests if a target-candidate (tc) is a target
; a tc is a target if its last character is
; a colon...
(let ((is-target? (lambda (tc)
(regexp-search
(rx (: any #\: eos))
tc))))
(+ 1 (list-index is-target? str-l))))))
(cond
((null? deps-l) #f)
(else
(cons
; this is a pair list -> the colon can be deleted
(map delete-colon
(take deps-l (last-target-element deps-l)))
(list
(drop deps-l (last-target-element deps-l))))))))))
(t-p-pair (cook-deps (raw-deps f i-dirs))))))
(define add-entry
(lambda (k d a)
(let
((tp (lambda (f i)
(targets-prereqs f i))))
(alist-cons (car (tp k d)) (cdr (tp k d)) a))))
(define include-dirs
(list
"./"
"/usr/include"
"/usr/src/linux/include"))
(define target-lookup-table
(add-entry
"./scanme.c"
include-dirs
'()))
(define target-lookup-table
(add-entry
"./it.h"
include-dirs
target-lookup-table))
(display target-lookup-table)
(newline)

6
job.scm
View File

@ -15,11 +15,11 @@
(define (display-job-output j-res)
(display
(string-append
";;; job finished with exitno: "
"job finished with output exitno:\n"
(number->string (job-res-errno j-res)) "\n"
";;; job finished with stdout:\n"
"job finished with output stdout:\n"
(job-res-stdout j-res) "\n"
";;; job finished with stderr:\n"
"job finished with output stderr:\n"
(job-res-stderr j-res) "\n"))
(newline))

31
jobd.scm
View File

@ -1,6 +1,7 @@
(define-record-type :jobd
(really-make-jobd version-s job-c sig-mc)
jobd?
(version-s jobd-version-s)
(job-c jobd-job-c)
(sig-mc jobd-sig-mc))
@ -11,21 +12,21 @@
jobber-sig-index
(shutdown stop continue))
(define (cml-fork/collecting->rv id job-desc sig-ch)
(define (cml-fork-collecting->rv id job-desc sig-ch)
(let* ((ch (cml-sync-ch/make-channel))
(cwd (job-desc-wd job-desc))
(env (job-desc-env job-desc))
(cmd (job-desc-cmd job-desc))
(fds (list 1 2))
(thunk (lambda () (with-total-env ,env (with-cwd cwd cmd))))
(res-rv (cml-fork/collecting fds sig-ch thunk)))
(res-rv (cml-fork-collecting fds sig-ch thunk)))
(spawn
(lambda ()
(let ((results (cml-rv/sync res-rv)))
(cml-sync-ch/send ch (make-job-res (list-ref results 0)
(list-ref results 1)
(list-ref results 2)))))
(format #t "cml-fork/collecting->rv (no. ~a)\n" id))
(format #t "cml-fork-collecting->rv (no. ~a)\n" id))
(cml-sync-ch/receive-rv ch)))
;;; ->alist?
@ -39,15 +40,15 @@
(cml-sync-ch/send to-process-element signal/stop))
((eq? (jobber-sig-name sig) 'continue)
(cml-sync-ch/send to-process-element signal/cont))
(else (error "jobber-sig->signal: unknown jobber-sig."))))
(else (error "jobber-sig->signal: unknown object."))))
(else (error "jobber: jobber-sig->signal received unknown jobber-sig."))))
(else (error "jobber: jobber-sig->signal received unknown object."))))
(define (job-desc->job-res id sig-mport j-des+res-ch)
(let* ((j-des (car j-des+res-ch))
(res-ch (cdr j-des+res-ch))
(to-process-element (cml-sync-ch/make-channel))
(sig-rcv-rv (cml-mcast-ch/mcast-port-receive-rv sig-mport))
(job-res-rv (cml-fork/collecting->rv id j-des to-process-element)))
(job-res-rv (cml-fork-collecting->rv id j-des to-process-element)))
(let finish-job ()
(cml-rv/select
(cml-rv/wrap sig-rcv-rv
@ -75,23 +76,25 @@
(loop))))
(format #t "jobber (no. ~a)\n" id)))
(define jobd-vers "jobd-0.0.1")
(define (make-jobd)
(let* ((job-ch (cml-async-ch/make-async-channel))
(let* ((version jobd-vers)
(job-ch (cml-async-ch/make-async-channel))
(sig-m-ch (cml-mcast-ch/make-mcast-channel))
(start-jobber (lambda (id)
(let ((new-mport (cml-mcast-ch/mcast-port sig-m-ch)))
(jobber id job-ch new-mport)))))
(jobber id job-ch (cml-mcast-ch/mcast-port sig-m-ch)))))
(for-each start-jobber (enumerate jobbers))
(really-make-jobd job-ch sig-m-ch))))
(really-make-jobd version job-ch sig-m-ch)))
(define (execute-rv job-desc jobd)
(define (version jobd)
(jobd-version-s jobd))
(define (execute job-desc jobd)
(let ((res-ch (cml-async-ch/make-async-channel)))
(cml-async-ch/send-async (jobd-job-c jobd) (cons job-desc res-ch))
(cml-async-ch/receive-async-rv res-ch)))
(define (execute job-desc jobd)
(cml-rv/sync (execute-rv job-desc jobd)))
(define (shutdown jobd)
(cml-mcast-ch/mcast (jobd-sig-mc jobd) (jobber-sig shutdown)))

105
macros.scm
View File

@ -1,105 +0,0 @@
(define-syntax makefile
(syntax-rules (pred)
((makefile ?clauses ...)
(let ((id=? string=?))
(clauses->lists id=? () () ?clauses ...)))
((makefile (pred id=?) ?clauses ...)
(clauses->lists id=? () () ?clauses ...))))
(define-syntax clauses->lists
(syntax-rules (common-% common-rx)
((clauses->lists pred (?rc0 ...) (?func1 ...) (common-% ?%0 ...) ?clause1 ...)
(clauses->lists pred
(?rc0 ...)
(?func1 ... (common-%-clause->func pred ?%0) ...)
?clause1 ...))
((clauses->lists pred (?rc0 ...) (?func1 ...) (common-rx ?rx0 ...) ?clause1 ...)
(clauses->lists pred
(?rc0 ...)
(?func1 ... (common-rx-clause->func pred ?rx0) ...)
?clause1 ...))
((clauses->lists pred (?rc1 ...) (?func0 ...) ?clause0 ?clause1 ...)
(clauses->lists pred
(?rc1 ... (clause->rc pred ?clause0))
(?func0 ...)
?clause1 ...))
((clauses->lists pred (?rc0 ...) (?func0 ...))
(rcs+commons->rules pred
(list ?rc0 ...)
(list ?func0 ...)))))
(define-syntax common-rx-clause->func
(syntax-rules ()
((common-rx-clause->func pred (?func ?target (?pre0 ...) ?act0 ...))
(common-rx-clause->func-tmp () pred (?func ?target (?pre0 ...) ?act0 ...)))))
(define-syntax common-rx-clause->func-tmp
(syntax-rules ()
((common-rx-clause->func (tmp1 ...) pred (?func ?target-rx () ?act0 ...))
(lambda (maybe-target)
(let ((trx ?target-rx)
(thunk (lambda () ?act0 ...))
(prereqs (list tmp1 ...)))
(common->func maybe-target trx pred ?func ?target-rx prereqs thunk))))
((common-rx-clause->func-tmp (tmp1 ...)
pred
(?func ?target (?pre0 ?pre1 ...) ?act0 ...))
(let ((tmp2 ?pre0))
(common-rx-clause->func-tmp (tmp1 ... tmp2)
pred
(?func ?target (?pre1 ...) ?act0 ...))))))
(define-syntax common-%-clause->func
(syntax-rules ()
((common-%-clause->func pred (?func ?target ?prereqs ?act0 ...))
(common-%-clause->func-tmp () pred (?func ?target ?prereqs ?act0 ...)))))
(define-syntax common-%-clause->func-tmp
(syntax-rules ()
((common-%-clause->func-tmp (tmp1 ...) pred (?func ?target () ?act0 ...))
(lambda (maybe-target)
(let ((trx (%-pattern->rx ?target))
(thunk (lambda () ?act0 ...))
(prereqs (list tmp1 ...)))
(common->func maybe-target trx pred ?func ?target prereqs thunk))))
((common-%-clause->func-tmp (tmp1 ...)
pred
(?func ?target (?pre0 ?pre1 ...) ?act0 ...))
(let ((tmp2 ?pre0))
(common-%-clause->func-tmp (tmp1 ... tmp2)
pred
(?func ?target (?pre1 ...) ?act0 ...))))
((common-%-clause->func-tmp () pred (?func ?target ?prereqs ?act0 ...))
(let ((prereqs ?prereqs))
(common-%-clause->func-tmp () pred (?func ?target prereqs ?act0 ...))))))
(define-syntax clause->rc
(syntax-rules ()
((clause->rc pred (?func ?target (?prereq0 ...) ?action0 ...))
(clause->rc-tmp () pred (?func ?target (?prereq0 ...) ?action0 ...)))))
(define-syntax clause->rc-tmp
(syntax-rules ()
((clause->rc-tmp (tmp1 ...) pred (?func ?target () ?action0 ...))
(let ((target ?target)
(prereqs (list tmp1 ...)))
(make-rule-cand target
prereqs
(lambda args
(let ((init-state (last args)))
(cons (?func target (list tmp1 ...))
init-state)))
(lambda args
(let ((cooked-state (last args))
(results (cdr (reverse (cdr args)))))
(cons (bind-all-fluids target prereqs results
(lambda () ?action0 ...))
cooked-state))))))
((clause->rc-tmp (tmp1 ...)
pred
(?func ?target (?prereq0 ?prereq1 ...) ?action0 ...))
(let ((tmp2 ?prereq0))
(clause->rc-tmp (tmp1 ... tmp2)
pred
(?func ?target (?prereq1 ...) ?action0 ...))))))

69
make-rule-no-cml.scm
View File

@ -18,10 +18,28 @@
;;; are almost the same functions
(define (rule-set-add rule rule-set)
(let ((listen-ch #f))
(if (not (assq rule (rule-set-rules rule-set)))
(if (not (assq rule rule-set))
(make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set)))
(error "make-rule: rule already exists."))))
(define-syntax rule-wants-build?*
(syntax-rules ()
((rule-wants-build?* ?rule ?init-state)
((rule-wants-build? ?rule) ?init-state))
((rule-wants-build?* ?rule '() ?init-state)
((rule-wants-build? ?rule) ?init-state))
((rule-wants-build?* ?rule (?p0-res ?p1-res ...) ?init-state)
((rule-wants-build? ?rule) ?p0-res ?p1-res ... ?init-state))))
(define-syntax rule-build-func*
(syntax-rules ()
((rule-build-func* ?rule ?cooked-state)
(((rule-build-func ?rule) ?cooked-state)))
((rule-build-func* ?rule '() ?cooked-state)
(((rule-build-func ?rule) ?cooked-state)))
((rule-build-func* ?rule ?wants-build?-result (?p0 ?p1 ...) ?cooked-state)
(((rule-build-func ?rule) ?wants-build?-result ?p0 ?p1 ... ?cooked-state)))))
;;;
;;; RULE-RESULT
;;;
@ -39,48 +57,17 @@
(wants-build?-result rule-result-wants-build?)
(build-func-result rule-result-build-func))
;;; a named function mainly for tracing purposes
(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))))))
;;; a named function mainly for tracing purposes
(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-make rule init-state rule-set)
(let* ((prereqs (rule-prereqs rule))
(prereqs-results (map (lambda (prereq)
(if (assq prereq (rule-set-rules rule-set))
(rule-make prereq init-state rule-set)
(error "prerequisite is not in rule-set!")))
prereqs))
(wants-build?-result (apply-wants-build? rule prereqs
prereqs-results init-state))
;;; (wants-build?-result (if (null? prereqs)
;;; ((rule-wants-build? rule) init-state)
;;; (apply (rule-wants-build? rule)
;;; (append prereqs-results
;;; (list init-state)))))
(let* ((pre-results (map (lambda (prereq)
(if (assq prereq (rule-set-rules rule-set))
(rule-make prereq init-state rule-set)
(error "prerequisite is not in rule-set!")))
(rule-prereqs rule)))
(wants-build?-result (rule-wants-build?* rule pre-results init-state))
(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)
;;; (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
(rule-build-func* rule build-required?
pre-results cooked-state))
(make-rule-result wants-build?-result #f))))

222
make-rule.scm
View File

@ -23,12 +23,12 @@
;;; RULE-SET
;;;
;;; (make-empty-rule-set) ---> rule-set
;;; (rule-set-add rule 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))
(rules rule-set-rules))
(define (make-empty-rule-set)
(make-rule-set '()))
@ -40,12 +40,10 @@
(error "make-rule: rule already exists."))))
(define (rule-set-get-listen-ch rule rule-set)
(let ((maybe-rule (assoc rule (rule-set-rules rule-set))))
(if (and maybe-rule
(pair? maybe-rule)
(is-collect&reply-channel? (cdr maybe-rule)))
(cdr maybe-rule)
(error "rule not found in 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
@ -64,32 +62,20 @@
(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)
(start-threads 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))
(link (make-link client server))
(recipient (car link)))
(recipient (make-link client server)))
(send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
(let ((res (tagged-msg-stripped (send&collect/receive client))))
(stop-threads init-state rule-set)
res)))
(tagged-msg-stripped (send&collect/receive client))))
(define-enumerated-type rule-cmd :rule-cmd
is-rule-cmd?
@ -98,126 +84,82 @@
rule-cmd-index
(make link shutdown))
;;; this only works if there are no duplicates in list
(define (position< maybe-lesser maybe-greater objects)
(if (null? objects)
(error "position< has empty objects-list.")
(let search-objects ((current (car objects))
(todo (cdr objects)))
(cond
((= (tagged-msg-tag maybe-lesser) current) #t)
((= (tagged-msg-tag maybe-greater) current) #f)
((null? todo)
(error "position<: maybe-lesser or maybe-greater not found."
maybe-lesser maybe-greater))
(else (search-objects (car todo) (cdr todo)))))))
(define (rule-node/sort-msgs unsorted to-order)
(map tagged-msg-stripped
(sort (lambda (maybe-lesser maybe-greater)
(position< maybe-lesser maybe-greater to-order))
unsorted (list))))
(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/prereqs-results rule connect-ch recipients)
;;; (let ((unsorted-msgs (map (lambda (recipient)
;;; (let ((tmsg (make-tagged-msg recipient
;;; (rule-cmd make))))
;;; (send&collect/send connect-ch tmsg)
;;; (send&collect/receive connect-ch)))
;;; recipients)))
;;; (rule-node/sort-msgs unsorted-msgs recipients)))
(define (rule-node/prereqs-results rule connect-ch recipients)
(for-each (lambda (recipient)
(let ((tmsg (make-tagged-msg recipient (rule-cmd make))))
(send&collect/send connect-ch tmsg)))
recipients)
(let ((unsorted-msgs (map (lambda (ignore)
(send&collect/receive connect-ch))
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))))))
;;; 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 (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
(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))))))
(let* ((prereqs-results (rule-node/get-prereqs-results rule connect-ch
recipients init-state))
(wants-build?-result (call-with-values
(lambda ()
(apply values (append prereqs-results
(list init-state))))
(rule-wants-build? rule)))
(build-required? (car wants-build?-result))
(cooked-state (cdr wants-build?-result)))
(if build-required?
(make-rule-result wants-build?-result
(call-with-values
(lambda ()
(apply values (append (list build-required?)
prereqs-results
(list cooked-state))))
(rule-build-func rule)))
(make-rule-result wants-build?-result #f))))
(define (rule-node/make-links rule connect-ch rule-set)
(let ((listen-chs (map (lambda (prereq-rule)
(cdr (assoc prereq-rule (rule-set-rules rule-set))))
(rule-prereqs rule))))
(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 (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))
(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))
(get-rcpts (lambda ()
(map car (rule-node/make-links rule connect-ch rule-set))))
(do-answer (lambda (tmsg rcpts)
(let* ((sender (tagged-msg-tag tmsg))
(cmd (tagged-msg-stripped tmsg))
(result (rule-node/make rule listen-ch connect-ch
rcpts init-state))
(reply (make-tagged-msg sender result)))
(collect&reply/send listen-ch reply)))))
(let ((connect-ch (send&collect/make-channel)))
(spawn
(lambda ()
;;; (display (lookup-target rule target/rule-alist)) (newline)
;;
;; 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))
(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)))
(?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/make-links rule connect-ch rule-set)))
(let ((res (rule-node/make rule listen-ch connect-ch
?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) ?recipients)))
'rule-node)))

193
make.scm
View File

@ -1,193 +0,0 @@
(define (make rules targets . maybe-args)
(let-optionals maybe-args ((pred string=?)
(init-state (list)))
(let* ((rule-set (rules->rule-set rules))
(target-rules (map (lambda (target)
(lookup-rule pred target rules))
targets)))
(map (lambda (t)
(rule-make t init-state rule-set))
target-rules))))
(define (make-rc target prereqs out-of-date?-func thunk)
(make-rule-cand target
prereqs
(lambda args
(let ((init-state (last args)))
(cons (out-of-date?-func target prereqs)
init-state)))
(lambda args
(let ((cooked-state (last args))
(results (cdr (reverse (cdr args)))))
(cons (bind-all-fluids target prereqs results thunk)
cooked-state)))))
(define (file->rc target prereqs thunk)
(make-rc target prereqs file thunk))
(define (head->rc target prereqs thunk)
(make-rc target prereqs head thunk))
(define (tail->rc target prereqs thunk)
(make-rc target prereqs tail thunk))
(define (once->rc target prereqs thunk)
(make-rc target prereqs once thunk))
(define (all->rc target prereqs thunk)
(make-rc target prereqs all thunk))
(define (always->rc target prereqs thunk)
(make-rc target prereqs always thunk))
(define (perms->rc target prereqs thunk)
(make-rc target prereqs perms thunk))
(define (md5->rc target prereqs thunk)
(make-rc target prereqs md5 thunk))
(define (md5-perms->rc target prereqs thunk)
(make-rc target prereqs md5-perms thunk))
(define (paranoid->rc target prereqs thunk)
(make-rc target prereqs paranoid thunk))
(define (subst-% pattern match)
(regexp-substitute/global #f (rx (: (submatch (: bos (* any)))
(submatch "%")
(submatch (: (* any) eos))))
pattern 'pre 1 match 3 'post))
(define (%-pattern->match pattern no)
(let ((re (rx (: (submatch (: bos (* any)))
(submatch "%")
(submatch (: (* any) eos)))))
(found-%? (regexp-search (rx (: "%")) pattern)))
(if found-%?
(match:substring (regexp-search re pattern) no)
(if (= no 2) pattern ""))))
(define (%-pattern->rx pattern)
(let* ((left (%-pattern->match pattern 1))
(middle (%-pattern->match pattern 2))
(right (%-pattern->match pattern 3))
(target-rx (if (string=? "%" middle)
(rx (: (submatch (: bos ,left))
(submatch (* any))
(submatch (: ,right eos))))
(rx (: (submatch (: bos ,left))
(submatch ,middle)
(submatch (: ,right eos)))))))
target-rx))
(define (file-rx target prereqs thunk)
(rx->func string=? target prereqs file thunk))
(define (head-rx target prereqs thunk)
(rx->func string=? target prereqs head thunk))
(define (tail-rx target prereqs thunk)
(rx->func string=? target prereqs tail thunk))
(define (once-rx target prereqs thunk)
(rx->func string=? target prereqs once thunk))
(define (all-rx target prereqs thunk)
(rx->func string=? target prereqs all thunk))
(define (always-rx target prereqs thunk)
(rx->func string=? target prereqs always thunk))
(define (perms-rx target prereqs thunk)
(rx->func string=? target prereqs perms thunk))
(define (md5-rx target prereqs thunk)
(rx->func string=? target prereqs md5 thunk))
(define (md5-perms-rx target prereqs thunk)
(rx->func string=? target prereqs md5-perms thunk))
(define (paranoid-rx target prereqs thunk)
(rx->func string=? target prereqs paranoid thunk))
(define (rx->func pred target-rx prereqs out-of-date?-func thunk)
(lambda (maybe-target)
(common->func maybe-target target-rx pred
out-of-date?-func target-rx prereqs thunk)))
(define (file-% target prereqs thunk)
(%->func string=? target prereqs file thunk))
(define (head-% target prereqs thunk)
(%->func string=? target prereqs head thunk))
(define (tail-% target prereqs thunk)
(%->func string=? target prereqs tail thunk))
(define (once-% target prereqs thunk)
(%->func string=? target prereqs once thunk))
(define (all-% target prereqs thunk)
(%->func string=? target prereqs all thunk))
(define (always-% target prereqs thunk)
(%->func string=? target prereqs always thunk))
(define (perms-% target prereqs thunk)
(%->func string=? target prereqs perms thunk))
(define (md5-% target prereqs thunk)
(%->func string=? target prereqs md5 thunk))
(define (md5-perms-% target prereqs thunk)
(%->func string=? target prereqs md5-perms thunk))
(define (paranoid-% target prereqs thunk)
(%->func string=? target prereqs paranoid thunk))
(define (%->func pred target-pattern prereqs out-of-date?-func thunk)
(lambda (maybe-target)
(let ((target-rx (%-pattern->rx target-pattern)))
(common->func maybe-target target-rx pred
out-of-date?-func target-pattern prereqs thunk))))
(define (common->func maybe-target target-rx pred
out-of-date?-func target-pattern prereqs thunk)
(let* ((match-data (regexp-search target-rx maybe-target))
(maybe-target-matches (if match-data
(map (lambda (no)
(match:substring match-data no))
(list 1 2 3))
#f)))
(if maybe-target-matches
(let* ((left (list-ref maybe-target-matches 0))
(target-match (list-ref maybe-target-matches 1))
(right (list-ref maybe-target-matches 2))
(target-name (string-append left target-match right))
(cooked-prereqs (map (lambda (prereq)
(if (string? prereq)
(subst-% prereq target-match)
prereq))
prereqs)))
(make-rule-cand target-name
cooked-prereqs
(lambda args
(let ((init-state (last args)))
(cons (bind-fluids-common
target-name left target-match right
(lambda ()
(out-of-date?-func target-name
cooked-prereqs)))
init-state)))
(lambda args
(let ((cooked-state (last args))
(prereqs-results (cdr (reverse (cdr args)))))
(cons (bind-fluids-common
target-name left target-match right
(lambda ()
(bind-all-fluids target-name
cooked-prereqs
prereqs-results
thunk)))
cooked-state)))))
#f)))

101
makefile-diplom.scm
View File

@ -1,101 +0,0 @@
(define-structure makefile
(export fix-broken-urls
make-all!
make-pdf!
make-ps!
make-clean!
make-mrproper!)
(open scheme-with-scsh
srfi-1
srfi-9
macros
make
to-rule-set
templates
autovars)
(begin
(define clean-files
(list "scsh-make.aux" "scsh-make.log" "scsh-make.blg"))
(define mrproper-files
(list "scsh-make.pdf" "scsh-make.ps" "scsh-make.advi"
"scsh-make.bbl" "scsh-make.dvi" "fig/mcast.eps"))
(define (rerun? target prereqs)
(let ((re (rx (: "Rerun to get cross-references right."))))
(if (file-not-exists? target)
#t
(if (null? prereqs)
#f
(let* ((inp (open-input-file (car prereqs)))
(str (port->string inp)))
(close inp)
(regexp-search re str))))))
;; fix lines with broken wrapped URLs
(define (fix-broken-urls fname)
(let* ((re (rx (: (submatch (* (- any #\newline "%")))
(submatch "%" #\newline))))
(inp (open-input-file fname))
(s (port->string inp)))
(close inp)
(with-current-output-port
(open-output-file fname)
(display (regexp-substitute/global #f re s 'pre 1 'post)))))
(define rule-set
(makefile
(common-%
(file "fig/%.eps"
("fig/%.fig")
(run (fig2dev -L "eps" ,($<) ,($@))))
(file "png/%.eps"
("png/%.png")
(run (convert ,($<) ,($@))))
(file "jpg/%.eps"
("jpg/%.jpg")
(run (convert ,($<) ,($@))))
(file "%.advi"
("%.dvi")
(run (dvicopy ,($<) ,($@))))
(file "%.pdf"
("%.ps")
(run (ps2pdf ,"-sPAPERSIZE=a4" ,($<) ,($@))))
(file "%.ps"
("%.dvi")
(run (dvips -o ,($@) ,($<))))
(once "%.dvi"
("%.aux" "%.aux" "%.aux" "%.aux")
#t)
(rerun? "%.aux"
("%.log")
(run (latex ,($*))))
(file "scsh-make.log"
("scsh-make.tex" "scsh-make.bst"
"einleitung.tex" "konzepte.tex" "makefile.tex"
"embedded.tex" "jobserver.tex" "zusammenfassung.tex"
"fig/mcast.eps" "makefile.scm")
(run (latex ,($<)))
(run (bibtex ,"scsh-make"))
(fix-broken-urls "scsh-make.bbl")
(run (latex ,"scsh-make"))))
(always "all"
("scsh-make.pdf" "scsh-make.ps" "scsh-make.advi")
(display ";;; done: building ")
(display ($@))
(newline))
(always "clean"
()
(for-each (lambda (f) (delete-filesys-object f))
clean-files))
(always "mrproper"
()
(for-each (lambda (f) (delete-filesys-object f))
mrproper-files))))
(define (make-all!) (make rule-set (list "all")))
(define (make-pdf!) (make rule-set (list "scsh-make.pdf")))
(define (make-ps!) (make rule-set (list "scsh-make.ps")))
(define (make-clean!) (make rule-set (list "clean")))
(define (make-mrproper!) (make rule-set (list "mrproper")))))

82
makefile.scm
View File

@ -1,46 +1,42 @@
(define scsh-doc-dir (expand-file-name "~/src/scsh-0.6.6/doc/scsh-manual"))
(define work-dir scsh-doc-dir)
;; (define d "~/.tmp")
;;
;; (makefile
;; (makefile-rule (expand-file-name "skills.tex" d)
;; '()
;; (lambda ()
;; (with-cwd d (display "Top: skills.tex"))))
;; (makefile-rule (expand-file-name "skills.dvi" d)
;; (expand-file-name "skills.tex" d)
;; (lambda ()
;; (with-cwd d
;; (run (latex ,(expand-file-name "skills.tex" d))))))
;; (makefile-rule (expand-file-name "skills.pdf" d)
;; (expand-file-name "skills.dvi" d)
;; (lambda ()
;; (with-cwd d (run
;; (dvipdfm -o
;; ,(expand-file-name "skills.pdf" d)
;; ,(expand-file-name "skills.dvi" d)))))))
;;
;; (make (expand-file-name "skills.pdf" d))
(define tex-file (expand-file-name "test.tex" scsh-doc-dir))
(define dvi-file (expand-file-name "test.dvi" scsh-doc-dir))
(define pdf-file (expand-file-name "test.pdf" scsh-doc-dir))
(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"
(run (latex ,"/home/johannes/.tmp/skills.tex")))))
(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
(makefile
(makefile-rule tex-file
()
(lambda ()
(with-cwd work-dir (display "Top: skills.tex"))))
(makefile-rule pdf-file
(dvi-file)
(lambda ()
(with-cwd work-dir (run (dvipdfm -o ,pdf-file ,dvi-file)))))
(makefile-rule dvi-file
(tex-file)
(lambda ()
(with-cwd work-dir (run (latex ,tex-file))))))
(pdf-file)
"this is an empty init-state")
(make "/home/johannes/.tmp/skills.pdf")
;;; (make
;;; (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"
;;; (run (latex ,"/home/johannes/.tmp/skills.tex")))))
;;; (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"))))))
;;; ("/home/johannes/.tmp/skills.pdf"
;;; "/home/johannes/.tmp/skills.dvi"
;;; "/home/johannes/.tmp/skills.tex")
;;; "this is an empty init-state...")

91
makros.scm Normal file
View File

@ -0,0 +1,91 @@
(define *fname->rule*-table '())
(define rule-set (make-empty-rule-set))
;;; (*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? (assoc fname *fname->rule*-table)))
(if rule-found?
(error "There already exists a rule with this fname!")
(begin
(set! *fname->rule*-table
(alist-cons fname rule *fname->rule*-table))
(set! rule-set (rule-set-add rule rule-set))))))
(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 make-has-md5-digest=?
(syntax-rules ()
((make-has-md5-digest=? ?fingerprint ?target)
(lambda ?args
(cons (or (file-not-exists? ?target)
(=? (md5-digest-for-port (open-input-file ?target))
?fingerprint))
?args)))
((make-has-md5-digest=? ?fingerprint ?target ?prereq0 ...)
(lambda ?args
(cons (or (file-not-exists? ?target)
(=? (md5-digest->number (md5-digest-for-port
(open-input-file ?target)))
(md5-digest->number ?fingerprint)))
(last ?args))))))
(define-syntax makefile-rule
(syntax-rules ()
((makefile-rule '() ?prereqs ?action-thunk)
(error "Target specification in makefile-rule matches '()!"))
((makefile-rule (?target0 ...) ?prereqs ?action-thunk)
(begin
(makefile-rule ?target0 ?prereqs ?action-thunk)
...))
((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)
(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 ?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)))))))
(define-syntax with-is-out-of-date?-check-func
(syntax-rules ()
((with-is-out-of-date?-producer ?make-is-out-of-date? ?makefile-rule
(define-syntax makefile
(syntax-rules ()
; ((makefile ()) '())
((makefile ?rule0 ...)
(begin
(set! rule-set (make-empty-rule-set))
?rule0 ...))))
(define-syntax make
(syntax-rules ()
((make ?fname)
(rule-make (*fname->rule*-get ?fname)
"This is not an empty initial state."
rule-set))))

70
mcast-channels.scm
View File

@ -1,70 +0,0 @@
(define-record-type :mcast-channel
(really-make-mcast-channel msg-in fan-out reply-ch)
mcast-channel?
(msg-in mcast-channel-msg-in)
(fan-out mcast-channel-fan-out)
(reply-ch mcast-channel-reply-ch))
(define-record-type :mcast-port
(really-make-mcast-port channel)
mcast-port?
(channel channel->mcast-port))
(define-enumerated-type mcast-cmd :mcast-cmd
mcast-cmd?
the-mcast-cmds
mcast-cmd-name
mcast-cmd-index
(new-port new-sink))
(define (tee from-server to-sink)
(let ((to-mbox (make-channel)))
(spawn (lambda ()
(let drink-tee ((msg (receive from-server)))
(cond
((channel? to-sink)
(send to-sink msg)
(send to-mbox msg)))
(drink-tee (receive from-server))))
'mcast-channel/tee)
to-mbox))
(define (sink from-server)
(tee from-server #f))
(define (make-mcast-channel)
(let ((m-in (make-channel))
(f-out (make-channel))
(r-ch (make-channel)))
(spawn (lambda ()
(sink f-out)
(let lp ((msg (receive m-in)))
(cond
((eq? (mcast-cmd-name msg) 'new-port)
(let ((new-f-out (make-channel)))
(send r-ch (tee new-f-out f-out))
(set! f-out new-f-out)))
((eq? (mcast-cmd-name msg) 'new-sink)
(send r-ch (sink f-out)))
(else (send f-out msg)))
(lp (receive m-in))))
'mcast-channel/server)
(really-make-mcast-channel m-in f-out r-ch)))
(define (mcast mcast-ch msg)
(send (mcast-channel-msg-in mcast-ch) msg))
(define (mcast-port mcast-ch)
(send (mcast-channel-msg-in mcast-ch) (mcast-cmd new-port))
(really-make-mcast-port (receive (mcast-channel-reply-ch mcast-ch))))
(define (mcast-port-receive-rv mc-port)
(receive-rv (channel->mcast-port mc-port)))
(define (mcast-port-receive mc-port)
(sync (mcast-port-receive-rv mc-port)))
;; attach the sink to the first port after the server
(define (mcast-new-sink mcast-ch)
(send (mcast-channel-msg-in mcast-ch) (mcast-cmd new-sink))
(receive (mcast-channel-reply-ch mcast-ch)))

9
misc.scm
View File

@ -1,9 +0,0 @@
(define (insert pred item ls)
(if (or (null? ls) (pred item (car ls)))
(cons item ls)
(cons (car ls) (insert pred item (cdr ls)))))
(define (sort pred todo done)
(if (null? todo)
done
(sort pred (cdr todo) (insert pred (car todo) done))))

249
packages.scm
View File

@ -3,7 +3,6 @@
jobd?
version
execute
execute-rv
stop
continue
shutdown
@ -29,7 +28,7 @@
(define-interface cml-pe-interface
(export cml-fork
cml-fork/collecting))
cml-fork-collecting))
(define-structure cml-pe cml-pe-interface
(open scheme-with-scsh
@ -105,23 +104,17 @@
is-tagged-msg?
tagged-msg-tag
tagged-msg-stripped
make-cmd-msg
is-cmd-msg?
cmd-msg-cmd
cmd-msg-data
print-info
collect&reply/make-channel
send&collect/make-channel
is-collect&reply-channel?
is-send&collect-channel?
make-link
collect-cmd
collect&reply/receive
collect&reply/receive-rv
collect&reply/send
; collect&reply/send-rv
collect&reply/send-rv
send&collect/send
; send&collect/send-rv
send&collect/send-rv
send&collect/receive
send&collect/receive-rv))
@ -129,45 +122,46 @@
(open scheme-with-scsh
finite-types
srfi-9
; big-util ; for breakpoints
; let-opt ; for logging
threads
threads-internal
(with-prefix rendezvous cml-rv/)
(with-prefix rendezvous-channels cml-sync-ch/)
(with-prefix rendezvous-async-channels cml-async-ch/))
(with-prefix rendezvous-channels cml-sync-ch/))
(files collect-channels))
(define-interface make-rule-interface
(export make-rule
; set!-target/rule-alist
is-rule?
make-empty-rule-set
rule-set-add
is-rule-set?
make-rule-result
is-rule-result?
rule-result-wants-build?
rule-result-build-func
rule-make))
(define-structure make-rule-cml make-rule-interface
(define-structure make-rule make-rule-interface
(open scheme-with-scsh
locks
with-lock
threads
threads-internal
; big-util ; for breakpoints
srfi-1
srfi-9
finite-types
collect-channels
dfs
(with-prefix rendezvous cml-rv/)
(with-prefix rendezvous-channels cml-sync-ch/))
(files make-rule))
(define-structure make-rule-no-cml make-rule-interface
(define-interface make-rule-no-cml-interface
(export make-rule
is-rule?
make-empty-rule-set
rule-set-add
is-rule-set?
make-rule-result
is-rule-result?
rule-make))
(define-structure make-rule-no-cml make-rule-no-cml-interface
(open scheme-with-scsh
locks
with-lock
@ -175,209 +169,14 @@
srfi-9)
(files make-rule-no-cml))
(define-interface macros-interface
(export (makefile :syntax)))
(define-interface makros-interface
(export (make-is-out-of-date? :syntax)
(makefile :syntax)
(makefile-rule :syntax)
(make :syntax)))
(define-structure macros macros-interface
(define-structure makros makros-interface
(open scheme-with-scsh
srfi-1
to-rule-set
rule-cand
autovars
make)
(files macros))
(define-interface to-rule-set-interface
(export lookup-rc
lookup-fname
lookup-rule
rcs->dag
dag->rcs
rcs+commons->rules
rules->rule-set))
(define-structure to-rule-set to-rule-set-interface
(open scheme-with-scsh
srfi-1
srfi-9
templates
make-rule
common-rules
rule-cand
dfs)
(files to-rule-set))
(define-interface dfs-interface
(export make-dfs
dfs->list
dfs
dfs-dag-show
sort))
(define-structure dfs dfs-interface
(open scheme-with-scsh
finite-types
threads
srfi-1
srfi-9
let-opt
(with-prefix rendezvous-channels cml-sync-ch/))
(files dfs))
(define-interface templates-interface
(export file
head
tail
all
md5
always
perms
md5-perms
paranoid
once))
(define-structure templates templates-interface
(open scheme-with-scsh
common-rules
autovars
srfi-1
; big-util
srfi-13)
(files templates))
(define-interface autovars-interface
(export bind-fluids-common
bind-fluids-gnu
bind-all-fluids
fluid-$@
fluid-$<
fluid-$?
fluid-$^
fluid-$+
fluid-$*
fluid-$=*
fluid-$*=
fluid-$=*=
fluid-$@/
fluid-/$@
fluid-$=*=/
fluid-/$=*=
fluid-$</
fluid-/$<
fluid-$^/
fluid-/$^
fluid-$+/
fluid-/$+
fluid-$?/
fluid-/$?
$@
$<
$?
$^
$+
$*
$=*
$*=
$=*=
$@/
/$@
$=*=/
/$=*=
$</
/$<
$^/
/$^
$+/
/$+
$?/
/$?
bind-fluids-human))
(define-structure autovars autovars-interface
(open scheme-with-scsh
make-rule
thread-fluids
srfi-1
srfi-13)
(files autovars))
(define-interface common-rules-interface
(export common-rcs->common-rules
make-empty-common-rules
add-common-rules
search-match-in-common-rules))
(define-structure common-rules common-rules-interface
(open scheme-with-scsh
autovars
srfi-1
srfi-9
rule-cand
srfi-13)
(files common-rules))
(define-interface rule-cand-interface
(export make-rule-cand
is-rule-cand?
rule-cand-target
rule-cand-prereqs
rule-cand-up-to-date?-func
rule-cand-build-func))
(define-structure rule-cand rule-cand-interface
(open scheme-with-scsh
srfi-9)
(files rule-cand))
(define-interface make-interface
(export make
make-rc
file->rc
head->rc
tail->rc
once->rc
all->rc
always->rc
perms->rc
md5->rc
md5-perms->rc
paranoid->rc
%-pattern->match
%-pattern->rx
file-rx
head-rx
tail-rx
once-rx
all-rx
always-rx
perms-rx
md5-rx
md5-perms-rx
paranoid-rx
file-%
head-%
tail-%
once-%
all-%
always-%
perms-%
md5-%
md5-perms-%
paranoid-%
%->func
rx->func
common->func))
(define-structure make make-interface
(open scheme-with-scsh
srfi-1
; macros
let-opt
to-rule-set
templates
autovars
rule-cand
make-rule)
(files make))
(define make-rule make-rule-no-cml)
make-rule-no-cml)
(files makros))

33
pkg-def.scm
View File

@ -1,33 +0,0 @@
(define-package "scsh-make"
(0 1)
((install-lib-version (1 0)))
(write-to-load-script
`((config)
(load ,(absolute-file-name "packages.scm"
(get-directory 'scheme #f)))))
(install-file "SYNTAX" 'doc)
(install-file "README" 'doc)
(install-file "COPYING" 'doc)
(install-file "autovars.scm" 'scheme)
(install-file "cml-pe.scm" 'scheme)
(install-file "collect-channels.scm" 'scheme)
(install-file "common-rules.scm" 'scheme)
(install-file "dfs.scm" 'scheme)
(install-file "gcc-m.scm" 'scheme)
(install-file "jobd.scm" 'scheme)
(install-file "job.scm" 'scheme)
(install-file "macros.scm" 'scheme)
(install-file "make-rule-no-cml.scm" 'scheme)
(install-file "make-rule.scm" 'scheme)
(install-file "make.scm" 'scheme)
(install-file "mcast-channels.scm" 'scheme)
(install-file "packages.scm" 'scheme)
(install-file "rule-cand.scm" 'scheme)
(install-file "templates.scm" 'scheme)
(install-file "to-rule-set.scm" 'scheme))

7
rule-cand.scm
View File

@ -1,7 +0,0 @@
(define-record-type :rule-cand
(make-rule-cand target prereqs up-to-date?-func build-func)
is-rule-cand?
(target rule-cand-target)
(prereqs rule-cand-prereqs)
(up-to-date?-func rule-cand-up-to-date?-func)
(build-func rule-cand-build-func))

169
templates.scm
View File

@ -1,169 +0,0 @@
(define digest-extensions (list ".md5" ".fp" ".digest"))
(define (same-mtime? target prereqs)
(if (file-not-exists? target)
#t
(if (null? prereqs)
#f
(let ((target-mtime (file-last-mod target)))
(let for-each-prereq ((prereq (car prereqs))
(todo (cdr prereqs)))
(cond
((and (file-exists? prereq)
(> (file-last-mod prereq) target-mtime)) #t)
((null? todo) #f)
(else (for-each-prereq (car todo) (cdr todo)))))))))
(define (all-same-mtime? target prereqs)
(if (file-not-exists? target)
#t
(if (null? prereqs)
#f
(let ((target-mtime (file-last-mod target)))
(let for-each-prereq ((prereq (car prereqs))
(todo (cdr prereqs)))
(cond
((and (file-exists? prereq) (null? todo))
(> (file-last-mod prereq) target-mtime))
(else (and (and (file-exists? prereq)
(> (file-last-mod prereq) target-mtime))
(for-each-prereq (car todo) (cdr todo))))))))))
(define (same-perms? target prereqs)
(if (file-not-exists? target)
#t
(if (null? prereqs)
(error "no prerequisite in perms clause")
(cond
((file-not-exists? (car prereqs))
(error "nonexistent prerequisite" (car prereqs)))
(else (= (file-mode target) (file-mode (car prereqs))))))))
(define (checksum-from-file basename extension)
(let* ((bname (string-append basename extension))
(file (expand-file-name bname (cwd))))
(if (file-exists? file)
(let* ((inport (open-input-file file))
(strls (port->string-list inport)))
;; (display ";;; using : ") (display bname) (newline)
(if (null? strls)
#f
(string->number (car strls))))
#f)))
(define (checksum-into-file basename extension checksum)
(let* ((bname (string-append basename extension))
(file (expand-file-name bname (cwd)))
(outport (open-output-file file))
(str (number->string checksum)))
;; (display ";;; update : ") (display bname) (newline)
(with-current-output-port outport (begin (display str) (newline)))
(close outport)))
(define (checksum-for-file fname)
(let ((file (expand-file-name fname (cwd))))
(if (file-exists? file)
(md5-digest->number (md5-digest-for-port (open-input-file file)))
(error "checksum-for-file: file does not exist" file))))
;;; optimizations possible: global variable with known checksums
(define (get-file-checksum fname)
(checksum-for-file fname))
(define (same-checksum? target extensions prereqs)
(if (null? prereqs)
(error "same-checksum?: target has no prerequisites" target)
(let for-each-prereq ((current-prereq (car prereqs))
(previous-total 0)
(todo-prereqs (cdr prereqs)))
(let* ((current-file-sum (get-file-checksum current-prereq))
(current-total (if current-file-sum
(+ current-file-sum previous-total)
previous-total)))
(cond
((not (null? todo-prereqs))
(for-each-prereq (car todo-prereqs)
current-total
(cdr todo-prereqs)))
((not (null? extensions))
(let for-each-ext ((ext (car extensions))
(todo-exts (cdr extensions)))
(let ((known-sum (checksum-from-file target ext))
(target-name (string-append target ext)))
(cond
((and (file-not-exists? target-name) known-sum)
(begin
(checksum-into-file target ext current-total)
#f))
((and (file-not-exists? target-name) (null? todo-exts))
(begin
(checksum-into-file target
(last (reverse extensions))
current-total)
#f))
((and known-sum (= current-total known-sum)) #t)
((and known-sum (not (= current-total known-sum)))
(begin
(checksum-into-file target ext current-total)
#f))
((and (not known-sum) (not (null? todo-exts)))
(for-each-ext (car todo-exts) (cdr todo-exts)))
((and (not known-sum) (null? todo-exts))
(begin
(checksum-into-file target ext current-total)
#f))
(else (error "no match in same-checksum?"))))))
(else (error "no match in same-checksum?")))))))
(define (head target prereqs)
(if (file-not-exists? target)
#t
(if (null? prereqs)
#f
(let ((prereq (car prereqs)))
(if (file-not-exists? prereq)
(error "nonexistent prerequisite" prereq)
(> (file-last-mod prereq) (file-last-mod target)))))))
(define (tail target prereqs)
(if (file-not-exists? target)
#t
(if (null? prereqs)
#f
(if (null? (cdr prereqs))
#f
(let ((target-mtime (file-last-mod target)))
(let for-each-prereq ((prereq (cadr prereqs))
(todo (cddr prereqs)))
(cond
((and (file-exists? prereq)
(> (file-last-mod prereq) target-mtime)) #t)
((null? todo) #f)
(else (for-each-prereq (car todo) (cdr todo))))))))))
(define (always target prereqs) #t)
(define (once target prereqs)
(file-not-exists? target))
(define (file target prereqs)
(same-mtime? target prereqs))
(define (all target prereqs)
(all-same-mtime? target prereqs))
(define (md5 target prereqs)
(not (same-checksum? target digest-extensions prereqs)))
(define (perms target prereqs)
(not (same-perms? target prereqs)))
(define (md5-perms target prereqs)
(or (not (same-perms? target prereqs))
(not (same-checksum? target digest-extensions prereqs))))
(define (paranoid target prereqs)
(or (not (same-perms? target prereqs))
(same-mtime? target prereqs)
(not (same-checksum? target digest-extensions prereqs))))

34
test-jobd.scm
View File

@ -1,34 +0,0 @@
(define j-cwd "/home/johannes")
(define j-env (env->alist))
(define j-cmd "find /afs -name nonexistant")
(define j-descr (make-job-desc j-cwd j-env j-cmd))
(define j-cmds
(list (list "leo-dict" "detractors")
(list "ipcs" "-a")
(list "leo-dict" "schism")
(list "find" "studium" "-name" "*.txt")
(list "/bin/sh" "-c" "/bin/cat /var/tmp/*")
(list "ls" "-l")
(list "ps" "-eF")))
(define j-descrs
(let ((jdes (lambda (j-cmd) (make-job-desc j-cwd j-env j-cmd))))
(map jdes j-cmds)))
(define (do-some-jobs)
(let ((ch (cml-sync-ch/make-channel))
(start-parallel (jobd/set-jobbers! 3))
(jobd (jobd/make-jobd)))
(spawn
(lambda ()
(let* ((res-rvs (map jobd/execute j-descrs (circular-list jobd)))
(j-res (map cml-rv/sync res-rvs)))
(map display-job-output j-res)
(cml-sync-ch/send ch "done.")))
'test-jobd)
(sleep 50)
(jobd/stop jobd)
(sleep 40000)
(jobd/continue jobd)
(cml-sync-ch/receive ch)))

102
test-make-rule.scm
View File

@ -1,102 +0,0 @@
(define *a-out?* #t)
(define *b-out?* #t)
(define *c-out?* #t)
(define *d-out?* #t)
(define *e-out?* #t)
(define *f-out?* #t)
(define *g-out?* #t)
(define *h-out?* #t)
(define *i-out?* #t)
(define *j-out?* #t)
(define *k-out?* #t)
(define *l-out?* #t)
(define (reset!)
(set! *a-out?* #t)
(set! *b-out?* #t)
(set! *c-out?* #t)
(set! *d-out?* #t)
(set! *e-out?* #t))
(define (is-a-out? ist) (display "setting a\n") (cons *a-out?* ist))
(define (is-b-out? . args) (display "setting b\n") (cons *b-out?* (last args)))
(define (is-c-out? . args) (display "setting c\n") (cons *c-out?* (last args)))
(define (is-d-out? . args) (display "setting d\n") (cons *d-out?* (last args)))
(define (is-e-out? . args) (display "setting e\n") (cons *e-out?* (last args)))
(define (is-f-out? . args) (display "setting f\n") (cons *f-out?* (last args)))
(define (is-g-out? . args) (display "setting f\n") (cons *g-out?* (last args)))
(define (is-h-out? . args) (display "setting f\n") (cons *h-out?* (last args)))
(define (is-i-out? . args) (display "setting f\n") (cons *i-out?* (last args)))
(define (is-j-out? . args) (display "setting f\n") (cons *j-out?* (last args)))
(define (is-k-out? . args) (display "setting f\n") (cons *k-out?* (last args)))
(define (is-l-out? . args) (display "setting f\n") (cons *l-out?* (last args)))
(define (build-a b? . args)
(display "a\n") (set! *a-out?* #f) (cons *a-out?* (last args)))
(define (build-b b? . args)
(display "b\n") (set! *b-out?* #f) (cons *b-out?* (last args)))
(define (build-c b? . args)
(display "c\n") (set! *c-out?* #f) (cons *c-out?* (last args)))
(define (build-d b? . args)
(display "d\n") (set! *d-out?* #f) (cons *d-out?* (last args)))
(define (build-e b? . args)
(display "e\n") (set! *e-out?* #f) (cons *e-out?* (last args)))
(define (build-f b? . args)
(display "f\n") (set! *f-out?* #f) (cons *f-out?* (last args)))
(define (build-g b? . args)
(display "g\n") (set! *g-out?* #f) (cons *g-out?* (last args)))
(define (build-h b? . args)
(display "h\n") (set! *h-out?* #f) (cons *h-out?* (last args)))
(define (build-i b? . args)
(display "i\n") (set! *i-out?* #f) (cons *i-out?* (last args)))
(define (build-j b? . args)
(display "j\n") (set! *j-out?* #f) (cons *j-out?* (last args)))
(define (build-k b? . args)
(display "k\n") (set! *k-out?* #f) (cons *k-out?* (last args)))
(define (build-l b? . args)
(display "l\n") (set! *l-out?* #f) (cons *l-out?* (last args)))
;(define a (make-rule (list) is-a-out? build-a))
;(define b (make-rule (list a) is-b-out? build-b))
;(define c (make-rule (list b) is-c-out? build-c))
;(define d (make-rule (list b) is-d-out? build-d))
;(define e (make-rule (list c d) is-e-out? build-e))
;(define f (make-rule (list a b c d e) is-f-out? build-f))
;(define g (make-rule (list a b c d e f) is-g-out? build-g))
;(define h (make-rule (list a b c d e f g) is-h-out? build-h))
;(define i (make-rule (list a b c d e f g h) is-i-out? build-i))
;(define j (make-rule (list a b c d e f g h i) is-j-out? build-j))
;(define k (make-rule (list a b c d e f g h i j) is-k-out? build-k))
;(define l (make-rule (list a b c d e f g h i j k) is-l-out? build-l))
;(define rules (list a b c d e f g h i j k l))
;(define rules (list a b c d e))
(define (make-rule-set rules rule-set)
(cond
((null? rules) rule-set)
(else (make-rule-set (cdr rules) (rule-set-add (car rules) rule-set)))))
(define rule-set 'unset-rule-set)
(define (make!)
(define a (make-rule (list) is-a-out? build-a))
(define b (make-rule (list a) is-b-out? build-b))
(define c (make-rule (list b) is-c-out? build-c))
(define d (make-rule (list b) is-d-out? build-d))
(define e (make-rule (list b c d) is-e-out? build-e))
(define f (make-rule (list b c d e) is-f-out? build-f))
(define g (make-rule (list b c d e f) is-g-out? build-g))
(define h (make-rule (list b c d e f g) is-h-out? build-h))
(define i (make-rule (list a b c d e f g h) is-i-out? build-i))
(define j (make-rule (list a b c d e f g h i) is-j-out? build-j))
(define k (make-rule (list a b c d e f g h i j) is-k-out? build-k))
(define l (make-rule (list a b c d e f g h i j k) is-l-out? build-l))
(define rules (list a b c d e f g h i j k l))
(reset!)
(set! rule-set (make-rule-set rules (make-empty-rule-set)))
(rule-make l '() rule-set))
;(rule-make d '() rule-set)
;(rule-make e '() rule-set)
;(rule-make c '() rule-set)

21
test-mcast-channels.scm
View File

@ -1,21 +0,0 @@
(define (test-it)
(let* ((ls (list "a" "b" "c" "d" "e" "f"))
(m-ch (make-mcast-channel))
(a-port (mcast-port m-ch))
(b-port (mcast-port m-ch))
(c-port (mcast-port m-ch))
(d-port (mcast-port m-ch))
(e-port (mcast-port m-ch))
(f-port (mcast-port m-ch))
(mcast-ports (list a-port b-port c-port d-port e-port f-port)))
(for-each (lambda (msg)
(spawn (lambda ()
(mcast m-ch msg))))
ls)
(for-each (lambda (mc-port)
(spawn (lambda ()
(let rcv-msg ((msg (mcast-port-receive mc-port)))
(display msg)
(newline)
(rcv-msg (mcast-port-receive mc-port))))))
mcast-ports)))

93
to-rule-set.scm
View File

@ -1,93 +0,0 @@
(define (rc->dfs-node rc)
(let ((target (rule-cand-target rc))
(prereqs (rule-cand-prereqs rc))
(wants-build? (rule-cand-up-to-date?-func rc))
(build-func (rule-cand-build-func rc)))
(make-dfs target prereqs (list wants-build? build-func))))
(define (rcs->dag rcs)
(map (lambda (rc)
(let ((target (rule-cand-target rc))
(prereqs (rule-cand-prereqs rc))
(wants-build? (rule-cand-up-to-date?-func rc))
(build-func (rule-cand-build-func rc)))
(make-dfs target prereqs (list wants-build? build-func))))
rcs))
(define (dag->rcs dag)
(map (lambda (node)
(let* ((ls (dfs->list node))
(target (list-ref ls 0))
(prereqs (list-ref ls 1))
(ignored (list-ref ls 2)))
(if ignored
(let ((wants-build? (car ignored))
(build-func (cadr ignored)))
(make-rule-cand target prereqs wants-build? build-func))
(error "node without wants-build? and build-func"))))
dag))
(define (lookup-rc pred rc rcs)
(let ((maybe-rc (find (lambda (current)
(pred (car rc) (car current)))
rcs)))
(if maybe-rc maybe-rc (error "lookup-rc: rc not found."))))
(define (lookup-fname pred fname rcs)
(let ((maybe-fname (find (lambda (current)
(pred fname (car current)))
rcs)))
(if maybe-fname maybe-fname #f)))
(define (lookup-rule pred fname rules)
(let ((maybe-rule (find (lambda (current)
(pred fname (car current)))
rules)))
(if maybe-rule
(cdr maybe-rule)
(error "lookup-rule: fname not found in rules."))))
(define (rcs+commons->rules pred rule-candidates common-rcs)
(let* ((common-rules (common-rcs->common-rules common-rcs))
(create-leaf (lambda (maybe-target)
(rc->dfs-node
(search-match-in-common-rules common-rules
maybe-target))))
(unsorted-dag (rcs->dag rule-candidates))
(sorted-dag (dfs unsorted-dag pred #t create-leaf))
(sorted-rcs (dag->rcs sorted-dag)))
;; (dfs-dag-show sorted-dag)
(if (not (null? sorted-rcs))
(let for-all-rcs ((rc (car sorted-rcs))
(todo (cdr sorted-rcs))
(last-done '()))
(let* ((target (rule-cand-target rc))
(prereqs (rule-cand-prereqs rc))
(wants-build? (rule-cand-up-to-date?-func rc))
(build-func (rule-cand-build-func rc))
(done (cons (cons target
(make-rule (map (lambda (prereq)
(lookup-rule pred
prereq
last-done))
prereqs)
wants-build?
build-func))
last-done)))
(if (null? todo)
done
(for-all-rcs (car todo) (cdr todo) done))))
sorted-rcs)))
(define (rules->rule-set rule-alist)
(if (not (null? rule-alist))
(let ((rules (map cdr rule-alist)))
(let for-each-rule ((current-rule (car rules))
(rules-to-do (cdr rules))
(rule-set (make-empty-rule-set)))
(let ((next-rule-set (rule-set-add current-rule rule-set)))
(if (not (null? rules-to-do))
(for-each-rule (car rules-to-do)
(cdr rules-to-do)
next-rule-set)
next-rule-set))))))