added some files:

sample makefile for building tex-stuff
  makefile-diplom.scm
  pkg-def.scm

SYNTAX

@@ -0,0 +1,97 @@
+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' ... }+ }+ + '"'

autovars.scm

@@ -0,0 +1,175 @@
+(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))))))

cml-pe.scm

@@ -0,0 +1,62 @@
+(define (cml-fork 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))
+	 (process (fork thunk))
+	 (proc-done-rv (cml-sync-ch/receive-rv ch)))
+
+    (spawn 
+      (lambda ()
+	(let lp ()
+	  (cml-rv/select 
+	   (cml-rv/wrap sig-rv
+			(lambda (sig) (if (not (wait process wait/poll)) 
+					  (begin (signal-process process sig)
+						 (lp)))))
+	   (cml-rv/wrap proc-done-rv
+			(lambda (res) (cml-sync-ch/send res-ch res))))))
+      (format #t "cml-fork: signals (for ~a)\n" (proc:pid process)))
+
+    (spawn (lambda ()
+	     (cml-sync-ch/send ch (wait process)))
+	   (format #t "cml-fork: waiting (for ~a)\n" (proc:pid process)))
+
+    (cml-sync-ch/receive-rv res-ch)))
+
+(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))
+	 ;; from scsh-0.6.6/scsh/scsh.scm
+	 (channels (map (lambda (ignore)
+			  (call-with-values temp-file-channel cons))
+			fds))
+	 (read-ports (map car channels))
+	 (write-ports (map cdr channels))
+	 (process (fork (lambda () 
+			  (for-each close-input-port read-ports)
+			  (for-each move->fdes write-ports fds)
+			  (apply exec-path (thunk)))))
+	 (proc-done-rv (cml-sync-ch/receive-rv ch)))
+
+    (spawn 
+      (lambda ()
+	(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))) 
+
+    (spawn 
+      (lambda ()
+	(let loop ()
+	  (cml-rv/select 
+	   (cml-rv/wrap sig-rv
+			(lambda (sig) (if (not (wait process wait/poll)) 
+					  (begin (signal-process process sig)
+						 (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)))
+
+    (for-each close-output-port write-ports)
+    (cml-sync-ch/receive-rv res-ch)))

collect-channels.scm

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

common-rules.scm

@@ -0,0 +1,50 @@
+(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)))))))

dfs.scm

@@ -0,0 +1,236 @@
+;;; 
+;;; 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)))))))

examples/README

@@ -0,0 +1,31 @@
+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.

examples/checksums.md5

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

examples/config.h

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

examples/main.c

@@ -0,0 +1,44 @@
+#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);
+
+}

examples/makefile-c.scm

@@ -0,0 +1,200 @@
+(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")))))

examples/makefile-common-rules.scm

@@ -0,0 +1,81 @@
+(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))))

examples/makefile-tex.scm

@@ -0,0 +1,40 @@
+(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))))

examples/manual.tex

@@ -0,0 +1,19 @@
+\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}

examples/mymath.c

@@ -0,0 +1,28 @@
+#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);
+
+}

examples/mymath.h

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

examples/test-embed.scm

@@ -0,0 +1,86 @@
+(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")))

examples/wildio.c

@@ -0,0 +1,28 @@
+#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;
+
+}

examples/wildio.h

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

gcc-m.scm

@@ -0,0 +1,110 @@
+#!/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)

job.scm

@@ -0,0 +1,25 @@
+(define-record-type :job-desc
+  (make-job-desc wd env cmd)
+  job-desc?
+  (wd job-desc-wd)
+  (env job-desc-env)
+  (cmd job-desc-cmd))
+
+(define-record-type :job-res
+  (make-job-res errno stdout stderr)
+  job-res?
+  (errno job-res-errno)
+  (stdout job-res-stdout)
+  (stderr job-res-stderr))
+
+(define (display-job-output j-res)
+  (display 
+   (string-append 
+    ";;; job finished with exitno: " 
+    (number->string (job-res-errno j-res)) "\n"
+    ";;; job finished with stdout:\n" 
+    (job-res-stdout j-res) "\n"
+    ";;; job finished with stderr:\n"
+    (job-res-stderr j-res) "\n"))
+  (newline))
+

jobd.scm

@@ -0,0 +1,113 @@
+(define-record-type :jobd
+  (really-make-jobd version-s job-c sig-mc)
+  jobd?
+  (job-c jobd-job-c)
+  (sig-mc jobd-sig-mc))
+
+(define-enumerated-type jobber-sig :jobber-sig
+  jobber-sig?
+  the-jobber-sigs
+  jobber-sig-name
+  jobber-sig-index
+  (shutdown stop continue))
+
+(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)))
+    (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))
+    (cml-sync-ch/receive-rv ch)))
+
+;;; ->alist?
+(define (jobber-sig->signal sig to-process-element)
+  (cond 
+   ((jobber-sig? sig)
+    (cond 
+     ((eq? (jobber-sig-name sig) 'shutdown) 
+	  (cml-sync-ch/send to-process-element signal/kill))
+     ((eq? (jobber-sig-name sig) 'stop) 
+	  (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."))))
+
+(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)))
+    (let finish-job ()
+      (cml-rv/select 
+       (cml-rv/wrap sig-rcv-rv
+		    (lambda (sig) 
+		      (jobber-sig->signal sig to-process-element)
+		      (finish-job)))
+       (cml-rv/wrap job-res-rv
+		    (lambda (res) 
+		      (cml-async-ch/send-async res-ch res)))))))
+
+(define (jobber id job-ch sig-mport)
+  (spawn 
+    (lambda () 
+      (let loop ()
+	(let ((new-job-rv (cml-async-ch/receive-async-rv job-ch))
+	      (sig-rcv-rv (cml-mcast-ch/mcast-port-receive-rv sig-mport)))
+	  (cml-rv/select 
+	   (cml-rv/wrap new-job-rv
+			(lambda (j-des+res-ch) 
+			  (job-desc->job-res id sig-mport j-des+res-ch)))
+	   (cml-rv/wrap sig-rcv-rv
+			(lambda (sig) 
+			  (if (eq? (jobber-sig-name sig) 'shutdown) 
+			      (terminate-current-thread)))))
+	   (loop))))
+    (format #t "jobber (no. ~a)\n" id)))
+
+(define (make-jobd)
+  (let* ((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)))))
+    (for-each start-jobber (enumerate jobbers))
+    (really-make-jobd job-ch sig-m-ch))))
+
+(define (execute-rv 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)))
+
+(define (stop jobd)
+  (cml-mcast-ch/mcast (jobd-sig-mc jobd) (jobber-sig stop)))
+
+(define (continue jobd)
+  (cml-mcast-ch/mcast (jobd-sig-mc jobd) (jobber-sig continue)))
+
+(define (enumerate n-max)
+  (cond 
+   ((> n-max 1) (append (enumerate (- n-max 1)) (list n-max)))
+   ((= n-max 1) (list n-max))
+   (else (error "n-max < 0"))))
+
+(define jobbers 2)
+
+(define (set-jobbers! n-of)
+  (set! jobbers n-of))

macros.scm

@@ -0,0 +1,105 @@
+(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 ...))))))

make-rule-no-cml.scm

@@ -1,38 +1,86 @@
 (define-record-type :rule
-  (really-make-rule prereqs wants-build? build-func)
+  (make-rule prereqs wants-build? build-func)
   is-rule?
   (prereqs rule-prereqs)
   (wants-build? rule-wants-build?)
   (build-func rule-build-func))
 
-(define rules (list))
+(define-record-type :rule-set
-(define lock-rules (make-lock))
+  (make-rule-set rules)
+  is-rule-set?
+ (rules rule-set-rules))
 
-(define (rule-make rule init-state)
+(define (make-empty-rule-set)
-  (let* ((res-pres (map (lambda (prereq) 
+  (make-rule-set '()))
-			  (rule-make prereq init-state))
-			(rule-prereqs rule)))
-	 (res-wants-build? (call-with-values 
-			       (lambda () 
-				 (apply values (append res-pres 
-						       (list init-state))))
-			     (rule-wants-build? rule)))
-	 (build? (car res-wants-build?))
-	 (cooked-state (cdr res-wants-build?)))
-    (if build?
-	(call-with-values 
-	    (lambda () 
-	      (apply values (append (list build?)
-				    res-pres
-				    (list cooked-state))))
-	  (rule-build-func rule))
-	res-wants-build?)))
 
-(define (make-rule prereqs wants-build? build-func)
+;;; listen-ch is a dummy here
-  (let ((rule (really-make-rule prereqs wants-build? build-func)))
+;;; now this and the one in make-rule.scm 
-    (with-lock lock-rules 
+;;; are almost the same functions
-      (lambda () 
+(define (rule-set-add rule rule-set)
-	(if (not (find (lambda (r) (eq? r rule)) rules))
+  (let ((listen-ch #f))
-	    (set! rules (cons rule rules))
+    (if (not (assq rule (rule-set-rules rule-set)))
+	(make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set)))
 	(error "make-rule: rule already exists."))))
-    rule))
+
+;;;
+;;; RULE-RESULT
+;;; 
+;;; (rule-result-wants-build? rule-result) --->  
+;;;    (wants-build?-result . cooked-state) oder (#f . cooked-state) 
+;;; 
+;;; (rule-result-build-func rule-result) --->  
+;;;    (build-func-result . end-state) oder #f 
+;;; 
+;;; (rule-make rule init-state rule-set) ---> rule-result
+;;; 
+(define-record-type :rule-result
+  (make-rule-result wants-build?-result build-func-result)
+  is-rule-result?
+  (wants-build?-result rule-result-wants-build?)
+  (build-func-result rule-result-build-func))
+
+;;; 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)))))
+	 (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 #f))))

make-rule.scm

@@ -1,16 +1,96 @@
-;;;   TODO:
-;;;   =====
 ;;;
-;;;    o  Zyklenerkennung?
+;;; RULE
-;;;    o  nicht benoetigte Threads runterfahren
+;;;
-
+;;; (make-rule prereqs wants-build? build-func) ---> rule
+;;;
+;;; prereqs: '(#{:rule} ...)
+;;; wants-build?: (lambda (res-p0 res-p1 ... res-pN init-state) body ...)
+;;;               res-pX: result of prerequisite-rule no. X
+;;;   (wants-build? res-p0 ... res-pN init-state) 
+;;;      ---> (res-wants-build? . cooked-state)
+;;; build-func: 
+;;;   (lambda (res-wants-build? res-p0 ... res-pN cooked-state) 
+;;;      ---> (res-build-func . end-state)
+;;;
 (define-record-type :rule
-  (really-make-rule prereqs wants-build? build-func)
+  (make-rule prereqs wants-build? build-func)
   is-rule?
   (prereqs rule-prereqs)
   (wants-build? rule-wants-build?)
   (build-func rule-build-func))
 
+;;;
+;;; RULE-SET
+;;;
+;;; (make-empty-rule-set) ---> rule-set
+;;; (rule-set-add rule rule-set) ---> rule-set
+;;;
+(define-record-type :rule-set
+  (make-rule-set rules)
+  is-rule-set?
+  (rules rule-set-rules))
+
+(define (make-empty-rule-set) 
+  (make-rule-set '()))
+
+(define (rule-set-add rule rule-set)
+  (let ((listen-ch (collect&reply/make-channel)))
+    (if (not (assq rule (rule-set-rules rule-set)))
+	(make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set)))
+	(error "make-rule: rule already exists."))))
+
+(define (rule-set-get-listen-ch rule rule-set)
+  (let ((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."))))
+
+;;;
+;;; RULE-RESULT
+;;; 
+;;; (rule-result-wants-build? rule-result) --->  
+;;;    (wants-build?-result . cooked-state) oder (#f . cooked-state) 
+;;; 
+;;; (rule-result-build-func rule-result) --->  
+;;;    (build-func-result . end-state) oder #f 
+;;; 
+;;; (rule-make rule init-state rule-set) ---> rule-result 
+;;; 
+(define-record-type :rule-result
+  (make-rule-result wants-build?-result build-func-result)
+  is-rule-result?
+  (wants-build?-result rule-result-wants-build?)
+  (build-func-result rule-result-build-func))
+
+(define (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)
+  (let* ((server (rule-set-get-listen-ch rule rule-set))
+	 (client (send&collect/make-channel))
+	 (link (make-link client server))
+ 	 (recipient (car link)))
+    (send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
+    (let ((res (tagged-msg-stripped (send&collect/receive client))))
+      (stop-threads init-state rule-set)
+      res)))
+
 (define-enumerated-type rule-cmd :rule-cmd
   is-rule-cmd?
   the-rule-cmds
@@ -18,98 +98,126 @@
   rule-cmd-index
   (make link shutdown))
 
-(define (rule-make rule init-state)
+;;; this only works if there are no duplicates in list
-  (let* ((server (let ((found? (assq rule rules)))
+(define (position< maybe-lesser maybe-greater objects)
-		   (if (is-collect&reply-channel? (cdr found?)) 
+  (if (null? objects) 
-		       (cdr found?) 
+      (error "position< has empty objects-list.")
-		       (error "rule-make: rule not found."))))
+      (let search-objects ((current (car objects))
-	 (client (send&collect/make-channel))
+			   (todo (cdr objects)))
-	 (recipient (make-link client server)))
+	(cond
-    (send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
+	 ((= (tagged-msg-tag maybe-lesser) current) #t)
-    (send&collect/send client (make-tagged-msg recipient init-state))
+	 ((= (tagged-msg-tag maybe-greater) current) #f)
-    (tagged-msg-stripped (send&collect/receive client))))
+	 ((null? todo) 
-
+	  (error "position<: maybe-lesser or maybe-greater not found."
-(define rules (list))
+		 maybe-lesser maybe-greater))
-(define lock-rules (make-lock))
+	 (else (search-objects (car todo) (cdr todo)))))))
-
-(define (make-rule prereqs wants-build? build-func)
-  (let ((rule (really-make-rule prereqs wants-build? build-func))
-	(listen-ch (collect&reply/make-channel)))
-    (with-lock lock-rules 
-      (lambda () 
-	(if (not (assq rule rules))
-	    (begin 
-	      (set! rules (alist-cons rule listen-ch rules))
-	      (rule-node rule listen-ch))
-	    (error "make-rule: rule already exists."))))
-    rule))
 
 (define (rule-node/sort-msgs unsorted to-order)
-  (map (lambda (pos)
+  (map tagged-msg-stripped
-	 (map (lambda (tmsg)
+       (sort (lambda (maybe-lesser maybe-greater) 
-		(let ((msg (tagged-msg-stripped tmsg))
+	       (position< maybe-lesser maybe-greater to-order))
-		      (sender (tagged-msg-tag tmsg)))
+	     unsorted (list))))
-		  (if (eq? sender pos)
-		      msg)))
-	      unsorted))
-       to-order))
 
-(define (rule-node/make rule recipients connect-ch listen-ch init-state)
+;;; (define (rule-node/prereqs-results rule connect-ch recipients)
-  (let* ((to-sort (map (lambda (recipient)
+;;;   (let ((unsorted-msgs (map (lambda (recipient) 
-			 (let ((tmsg-cmd (make-tagged-msg recipient 
+;;; 			      (let ((tmsg (make-tagged-msg recipient
-							  (rule-cmd make)))
+;;; 							   (rule-cmd make))))
-			       (tmsg-state (make-tagged-msg recipient 
+;;; 				(send&collect/send connect-ch tmsg)
-							    init-state)))
+;;; 				(send&collect/receive connect-ch)))
-			   (send&collect/send connect-ch tmsg-cmd)
+;;; 			    recipients)))
-			   (send&collect/send connect-ch tmsg-state)
+;;;     (rule-node/sort-msgs unsorted-msgs recipients)))
-			   (send&collect/receive connect-ch)))
-		       recipients))
-	 (res-pres (rule-node/sort-msgs to-sort recipients))
-	 (res-build? (call-with-values
-			 (lambda ()
-			   (apply values (append res-pres 
-						 (list init-state))))
-		       (rule-wants-build? rule)))
-	 (res-wants-build? (car res-build?))
-	 (cooked-state (cdr res-build?)))
-    (if res-wants-build? 
-	(let ((build-res (call-with-values 
-			     (lambda () 
-			       (apply values (append (list res-wants-build?)
-						     res-pres
-						     (list cooked-state))))
-			   (rule-build-func rule))))
-	  build-res)
-	(cons #t cooked-state))))
 
-(define (rule-node/recipients rule connect-ch)
+(define (rule-node/prereqs-results rule connect-ch recipients)
-  (let ((server-chs (map (lambda (r) 
+  (for-each (lambda (recipient) 
-			   (with-lock lock-rules
+	      (let ((tmsg (make-tagged-msg recipient (rule-cmd make))))
-			     (lambda () 
+		(send&collect/send connect-ch tmsg)))
-			       (cdr (assq r rules)))))
+	    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))))))
+
+(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))))))
+
+(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))))
-    (map (lambda (server-ch)
+    (map (lambda (listen-ch)
-	   (make-link connect-ch server-ch))
+           (make-link connect-ch listen-ch))
-	 server-chs)))
+         listen-chs)))
 
-(define (rule-node rule listen-ch)
+;;; (define (lookup-target rule rule-alist)
-  (let ((connect-ch (send&collect/make-channel)))
+;;;   (let ((maybe-targets (filter (lambda (r) (eq? (cdr r) rule)) rule-alist)))
+;;;     (if (not (null? maybe-targets))
+;;; 	(car (car maybe-targets))
+;;; 	(error "lookup-target: rule not found in rule-alist."))))
+;;; 
+;;; (define target/rule-alist '())
+;;; (define (set!-target/rule-alist alist) (set! target/rule-alist alist))
+
+(define (rule-node rule listen-ch init-state rule-set)
+  (let* ((connect-ch (send&collect/make-channel))
+	 (get-rcpts (lambda ()
+		      (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)))))
     (spawn
       (lambda () 
+;;;	(display (lookup-target rule target/rule-alist)) (newline)
 	(let node-loop ((tmsg (collect&reply/receive listen-ch))
-			(recipients #f))
+			(rcpts (get-rcpts)))
-	  (let ((sender (tagged-msg-tag tmsg))
-		(cmd (tagged-msg-stripped tmsg)))
 	  (cond
-	     ((eq? (rule-cmd-name cmd) 'make)
+	   ((eq? (rule-cmd-name (tagged-msg-stripped tmsg)) 'make)
-	      (if (not recipients) 
+	    (do-answer tmsg rcpts))
-		  (set! recipients (rule-node/recipients rule connect-ch)))
+	   ((eq? (rule-cmd-name (tagged-msg-stripped tmsg)) 'shutdown)
-	      (let* ((tmsg (collect&reply/receive listen-ch))
+	    (terminate-current-thread))
-		     (init-state (tagged-msg-stripped tmsg))
+	   (else (error "rule-node: no match")))
-		     (res (rule-node/make rule recipients
+	  (node-loop (collect&reply/receive listen-ch) rcpts)))
-					    connect-ch listen-ch init-state)))
-		(collect&reply/send listen-ch (make-tagged-msg sender res))))
-	     ((eq? (rule-cmd-name cmd) 'shutdown)
-	      (terminate-current-thread))))
-	  (node-loop (collect&reply/receive listen-ch) recipients)))
       'rule-node)))

make.scm

@@ -0,0 +1,193 @@
+(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)))

makefile-diplom.scm

@@ -0,0 +1,101 @@
+(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")))))

makefile.scm

@@ -1,25 +1,46 @@
-(makefile
+(define scsh-doc-dir (expand-file-name "~/src/scsh-0.6.6/doc/scsh-manual"))
- (makefile-rule "/home/johannes/.tmp/skills.tex"
+(define work-dir scsh-doc-dir)
-		'()
-		(lambda ()
-		  (with-cwd "/home/johannes/.tmp"
-			    (display "Top: /home/johannes/.tmp/skills.tex"))))
- (makefile-rule "/home/johannes/.tmp/skills.dvi"
-		"/home/johannes/.tmp/skills.tex"
-		(lambda ()
-		  (with-cwd "/home/johannes/.tmp"
-			    (begin 
-			      (run (latex   ,"/home/johannes/.tmp/skills.tex"))
-			      (run (dvicopy ,"/home/johannes/.tmp/skills.dvi"
-					    ,"/home/johannes/.tmp/skills.dvicopy"))
-			      (rename-file "/home/johannes/.tmp/skills.dvicopy"
-					   "/home/johannes/.tmp/skills.dvi" 
-					   #t)))))
- (makefile-rule "/home/johannes/.tmp/skills.pdf"
-		"/home/johannes/.tmp/skills.dvi"
-		(lambda ()
-		  (with-cwd "/home/johannes/.tmp"
-			    (run (dvipdfm -o ,"/home/johannes/.tmp/skills.pdf"
-					  ,"/home/johannes/.tmp/skills.dvi"))))))
 
-(make "/home/johannes/.tmp/skills.pdf")
+(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))
+
+(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 
+;;;   (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...")

makros.scm

@@ -1,64 +0,0 @@
-(define *fname->rule*-table '())
-
-;;; (*fname->rule*-get fname) ---> rule
-(define (*fname->rule*-get fname)
-  (let ((rule-found? (assoc fname *fname->rule*-table)))
-    (if rule-found? 
-	(cdr rule-found?))))
-
-;;; (*fname->rule*-add! fname) ---> {}
-(define (*fname->rule*-add! fname rule)
-  (let ((rule-found? (assq fname *fname->rule*-table)))
-    (if rule-found?
-	(error "There already exists a rule with this fname!")
-	(set! *fname->rule*-table 
-	      (alist-cons fname rule *fname->rule*-table)))))
-
-(define-syntax make-is-out-of-date? 
-  (syntax-rules () 
-    ((make-is-out-of-date? ?target '())
-     (lambda ?args
-       (cons (file-not-exists? ?target) ?args)))
-    ((make-is-out-of-date? ?target ?prereq0 ...)
-     (lambda ?args
-       (cons (or (file-not-exists? ?target)
-		 (> (file-last-mod ?prereq0) 
-		    (file-last-mod ?target))
-		 ...)
-	     (last ?args))))))
-
-(define-syntax makefile-rule
-  (syntax-rules ()
-    ((makefile-rule ?target '() ?action-thunk)
-     (*fname->rule*-add! ?target
-			 (make-rule '()
-				    (make-is-out-of-date? ?target)
-				    (lambda ?args (?action-thunk)))))
-    ((makefile-rule ?target ?prereq0 ?action-thunk)
-     (*fname->rule*-add! ?target
-			 (make-rule (list (*fname->rule*-get ?prereq0))
-				    (make-is-out-of-date? ?target ?prereq0)
-				    (lambda ?args (?action-thunk)))))
-    ((makefile-rule ?target (?prereq0 ...) ?action-thunk)
-     (begin 
-       (*fname->rule*-add! ?target
-			   (make-rule (list (*fname->rule*-get ?prereq0)
-					    ...)
-				      (make-is-out-of-date? ?target ?prereq0 ...)
-				      (lambda ?args (?action-thunk))))))
-    ((makefile-rule (?target0 ...) ?prereqs ?action-thunk)
-     (begin 
-       (makefile-rule ?target0 ?prereqs ?action-thunk)
-       ...))))
-
-(define-syntax makefile
-  (syntax-rules () 
-;    ((makefile ()) '())
-    ((makefile ?rule0 ...) 
-     (list ?rule0 ...))))
-
-(define-syntax make
-  (syntax-rules ()
-    ((make ?fname)
-     (rule-make (*fname->rule*-get ?fname)
-		"This is not an empty initial state."))))

mcast-channels.scm

@@ -0,0 +1,70 @@
+(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)))

misc.scm

@@ -0,0 +1,9 @@
+(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))))

packages.scm

@@ -1,19 +1,127 @@
+(define-interface jobd-interface
+  (export make-jobd
+	  jobd?
+	  version
+	  execute
+	  execute-rv
+	  stop
+	  continue
+	  shutdown
+	  set-jobbers!))
+
+(define-structure jobd jobd-interface
+  (open scheme-with-scsh
+	formats
+	srfi-1
+	(with-prefix srfi-8 srfi-8/)
+	srfi-9
+	srfi-11
+	threads
+	threads-internal
+	(with-prefix rendezvous cml-rv/)
+	(with-prefix mcast-channels cml-mcast-ch/)
+	(with-prefix rendezvous-channels cml-sync-ch/)
+	(with-prefix rendezvous-async-channels cml-async-ch/)
+	finite-types
+	job
+	cml-pe)
+  (files jobd))
+
+(define-interface cml-pe-interface
+  (export cml-fork
+	  cml-fork/collecting))
+
+(define-structure cml-pe cml-pe-interface
+  (open scheme-with-scsh
+	srfi-9
+	threads
+        (with-prefix rendezvous cml-rv/)
+	(with-prefix rendezvous-channels cml-sync-ch/))
+  (files cml-pe))
+
+(define-interface mcast-channels-interface
+  (export make-mcast-channel
+	  mcast-channel?
+	  mcast-port?
+	  mcast
+	  mcast-port
+	  mcast-port-receive
+	  mcast-port-receive-rv))
+
+(define-structure mcast-channels mcast-channels-interface
+  (open scheme
+        srfi-9
+        threads
+	finite-types
+        rendezvous
+        rendezvous-channels)
+  (files mcast-channels))
+
+(define-interface job-interface
+  (export make-job-desc
+	  job-desc?
+	  job-desc-wd
+	  job-desc-env
+	  job-desc-cmd
+	  make-job-res
+	  job-res?
+	  job-res-errno
+	  job-res-stdout
+	  job-res-stderr
+	  display-job-output))
+
+(define-structure job job-interface
+  (open scheme-with-scsh
+	srfi-9)
+  (files job))
+
+(define-structure test-jobd
+  (export do-some-jobs)
+  (open scheme-with-scsh
+	locks
+	threads
+	threads-internal
+	srfi-1
+	(with-prefix rendezvous cml-rv/)
+	(with-prefix rendezvous-channels cml-sync-ch/)
+	(with-prefix rendezvous-async-channels cml-async-ch/)
+	cml-pe
+	job
+	(with-prefix jobd jobd/))
+  (files test-jobd))
+
+(define-structure test-mcast-channels 
+  (export test-it)
+  (open scheme
+	srfi-9
+	threads
+	rendezvous
+	rendezvous-channels
+	mcast-channels)
+  (files test-mcast-channels))
+
 (define-interface collect-channels-interface
   (export make-tagged-msg
 	  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))
 
@@ -21,42 +129,45 @@
   (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-channels cml-sync-ch/)
+	(with-prefix rendezvous-async-channels cml-async-ch/))
   (files collect-channels))
 
 (define-interface make-rule-interface
   (export make-rule
+;	  set!-target/rule-alist
 	  is-rule?
-	  rule-prereqs
+	  make-empty-rule-set
-	  rule-wants-build?
+	  rule-set-add
-	  rule-build-func
+	  is-rule-set?
+	  make-rule-result
+	  is-rule-result?
+	  rule-result-wants-build?
+	  rule-result-build-func
 	  rule-make))
 
-(define-structure make-rule make-rule-interface
+(define-structure make-rule-cml 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-interface make-rule-no-cml-interface
+(define-structure make-rule-no-cml make-rule-interface
-  (export make-rule
-	  is-rule?
-	  rule-prereqs
-	  rule-wants-build?
-	  rule-build-func
-	  rule-make))
-
-(define-structure make-rule-no-cml make-rule-no-cml-interface
   (open scheme-with-scsh
 	locks
 	with-lock
@@ -64,14 +175,209 @@
 	srfi-9)
   (files make-rule-no-cml))
 
-(define-interface makros-interface
+(define-interface macros-interface
-  (export (make-is-out-of-date? :syntax)
+  (export (makefile :syntax)))
-	  (makefile :syntax)
-	  (makefile-rule :syntax)
-	  (make :syntax)))
 
-(define-structure makros makros-interface
+(define-structure macros macros-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 makros))
+  (files make))
+
+(define make-rule make-rule-no-cml)

pkg-def.scm

@@ -0,0 +1,33 @@
+(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))
+
+
+
+
+
+

rule-cand.scm

@@ -0,0 +1,7 @@
+(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))

templates.scm

@@ -0,0 +1,169 @@
+(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))))
+       

test-jobd.scm

@@ -0,0 +1,34 @@
+(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)))

test-make-rule.scm

@@ -0,0 +1,102 @@
+(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)
+

test-mcast-channels.scm

@@ -0,0 +1,21 @@
+(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)))

to-rule-set.scm

@@ -0,0 +1,93 @@
+(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))))))