Initial import.

SYNTAX

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

autovars.scm

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

cml-pe.scm

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

collect-channels.scm

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

common-rules.scm

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

dfs.scm

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

examples/README

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

examples/checksums.md5

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

examples/config.h

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

examples/main.c

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

examples/makefile-c.scm

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

examples/makefile-common-rules.scm

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

examples/makefile-tex.scm

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

examples/manual.tex

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

examples/mymath.c

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

examples/mymath.h

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

examples/test-embed.scm

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

examples/wildio.c

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

examples/wildio.h

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

gcc-m.scm

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

job.scm

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

jobd.scm

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

macros.scm

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

make-rule-no-cml.scm

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

@@ -23,12 +23,12 @@
 ;;; RULE-SET
 ;;;
 ;;; (make-empty-rule-set) ---> rule-set
-;;; (rule-set-add rule rule-set) ---> rule-set
+;;; (rule-set-add! rule rule-set) ---> rule-set
 ;;;
 (define-record-type :rule-set
   (make-rule-set rules)
   is-rule-set?
-  (rules rule-set-rules))
+ (rules rule-set-rules))
 
 (define (make-empty-rule-set) 
   (make-rule-set '()))
@@ -40,12 +40,10 @@
 	(error "make-rule: rule already exists."))))
 
 (define (rule-set-get-listen-ch rule rule-set)
-  (let ((maybe-rule (assoc rule (rule-set-rules rule-set))))
+  (let ((?thing (assq rule (rule-set-rules rule-set))))
-    (if (and maybe-rule 
+    (if (and ?thing (pair? ?thing) (is-collect&reply-channel? (cdr ?thing)))
-	     (pair? maybe-rule) 
+	(cdr ?thing)
-	     (is-collect&reply-channel? (cdr maybe-rule)))
+	(error "Rule not found in rule-set."))))
-	(cdr maybe-rule)
-	(error "rule not found in rule-set."))))
 
 ;;;
 ;;; RULE-RESULT
@@ -64,32 +62,20 @@
   (wants-build?-result rule-result-wants-build?)
   (build-func-result rule-result-build-func))
 
-(define (start-threads init-state rule-set)
-  (map (lambda (rule) 
-	 (let ((listen-ch (rule-set-get-listen-ch rule rule-set)))
-	   (rule-node rule listen-ch init-state rule-set)))
-       (map car (rule-set-rules rule-set))))
-
-(define (stop-threads init-state rule-set)
-  (map (lambda (rule) 
-	 (let* ((server (rule-set-get-listen-ch rule rule-set))
-		(client (send&collect/make-channel))
-		(link (make-link client server))
-		(recipient (car link))
-		(shutdown (make-tagged-msg recipient (rule-cmd shutdown))))
-	   (send&collect/send client shutdown)))
-       (map car (rule-set-rules rule-set))))
-
 (define (rule-make rule init-state rule-set)
-  (start-threads init-state rule-set)
+  ;;
+  ;; this could be rewritten in future
+  ;; 
+  ;; check for unused threads -> dont start them
+  ;;
+  (map (lambda (r) 
+	 (rule-node r (rule-set-get-listen-ch r rule-set) init-state rule-set))
+       (map car (rule-set-rules rule-set)))
   (let* ((server (rule-set-get-listen-ch rule rule-set))
 	 (client (send&collect/make-channel))
-	 (link (make-link client server))
+	 (recipient (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))))
+    (tagged-msg-stripped (send&collect/receive client))))
-      (stop-threads init-state rule-set)
-      res)))
 
 (define-enumerated-type rule-cmd :rule-cmd
   is-rule-cmd?
@@ -98,126 +84,82 @@
   rule-cmd-index
   (make link shutdown))
 
-;;; this only works if there are no duplicates in list
-(define (position< maybe-lesser maybe-greater objects)
-  (if (null? objects) 
-      (error "position< has empty objects-list.")
-      (let search-objects ((current (car objects))
-			   (todo (cdr objects)))
-	(cond
-	 ((= (tagged-msg-tag maybe-lesser) current) #t)
-	 ((= (tagged-msg-tag maybe-greater) current) #f)
-	 ((null? todo) 
-	  (error "position<: maybe-lesser or maybe-greater not found."
-		 maybe-lesser maybe-greater))
-	 (else (search-objects (car todo) (cdr todo)))))))
-
 (define (rule-node/sort-msgs unsorted to-order)
-  (map tagged-msg-stripped
+  (map (lambda (pos)
-       (sort (lambda (maybe-lesser maybe-greater) 
+	 (map (lambda (tmsg)
-	       (position< maybe-lesser maybe-greater to-order))
+		(let ((msg (tagged-msg-stripped tmsg))
-	     unsorted (list))))
+		      (sender (tagged-msg-tag tmsg)))
+		  (if (eq? sender pos)
+		      msg)))
+	      unsorted))
+       to-order))
 
-;;; (define (rule-node/prereqs-results rule connect-ch recipients)
+;;; send each prereq-thread a make command and the init-state
-;;;   (let ((unsorted-msgs (map (lambda (recipient) 
+;;; then wait for the results to return 
-;;; 			      (let ((tmsg (make-tagged-msg recipient
+;;; sort to the order they were sent and ciao
-;;; 							   (rule-cmd make))))
+(define (rule-node/get-prereqs-results rule connect-ch recipients init-state)
-;;; 				(send&collect/send connect-ch tmsg)
+  (rule-node/sort-msgs (map 
-;;; 				(send&collect/receive connect-ch)))
+			(lambda (recipient)
-;;; 			    recipients)))
+			  (send&collect/send connect-ch 
-;;;     (rule-node/sort-msgs unsorted-msgs recipients)))
+					     (make-tagged-msg recipient 
-
+							      (rule-cmd make)))
-(define (rule-node/prereqs-results rule connect-ch recipients)
+			  (send&collect/receive connect-ch))
-  (for-each (lambda (recipient) 
+			recipients)
-	      (let ((tmsg (make-tagged-msg recipient (rule-cmd make))))
+		       recipients))
-		(send&collect/send connect-ch tmsg)))
-	    recipients)
-  (let ((unsorted-msgs (map (lambda (ignore) 
-			      (send&collect/receive connect-ch))
-			    recipients)))
-    (rule-node/sort-msgs unsorted-msgs recipients)))
-
-;;; named function for tracing
-(define (apply-build-func build-required? rule prereqs prereqs-results cooked-state)
-  (let ((build-func (rule-build-func rule)))
-    (if (null? prereqs)
-	(build-func build-required? cooked-state)
-	(apply build-func
-	       (append (list build-required?) 
-		       prereqs-results (list cooked-state))))))
-
-;;; named function for tracing
-(define (apply-wants-build? rule prereqs prereqs-results init-state)
-  (let ((wants-build? (rule-wants-build? rule)))
-    (if (null? prereqs)
-	(wants-build? init-state)
-	(apply wants-build? (append prereqs-results (list init-state))))))
 
 (define (rule-node/make rule listen-ch connect-ch recipients init-state)
-  (let ((prereqs (rule-prereqs rule))
+  (let* ((prereqs-results (rule-node/get-prereqs-results rule connect-ch
-	(prereqs-results (rule-node/prereqs-results rule connect-ch recipients)))
+							 recipients init-state))
-    (let ((wants-build?-result 
+	 (wants-build?-result (call-with-values
-	   (apply-wants-build? rule prereqs prereqs-results init-state)))
+				  (lambda ()
-;;;     (let ((wants-build?-result (if (null? prereqs-results)
+				    (apply values (append prereqs-results
-;;; 				   ((rule-wants-build? rule) init-state)
+							  (list init-state))))
-;;; 				   (apply (rule-wants-build? rule)
+				(rule-wants-build? rule)))
-;;; 					  (append prereqs-results 
+	 (build-required? (car wants-build?-result))
-;;; 						  (list init-state))))))
+	 (cooked-state (cdr wants-build?-result)))
-      (let ((build-required? (car wants-build?-result))
+    (if build-required? 
-	    (cooked-state (cdr wants-build?-result)))
+	(make-rule-result wants-build?-result
-	(if build-required? 
+			  (call-with-values 
-	    (let* ((build-func (rule-build-func rule))
+			      (lambda () 
-;;; 		   (build-func-result (if (null? prereqs-results)
+				(apply values (append (list build-required?)
-;;; 					  (build-func build-required? cooked-state)
+						      prereqs-results 
-;;; 					  (apply build-func
+						      (list cooked-state))))
-;;; 						 (append (list build-required?)
+			    (rule-build-func rule)))
-;;; 							 prereqs-results 
+	(make-rule-result wants-build?-result #f))))
-;;; 							 (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) 
+  (let ((listen-chs (map (lambda (r) 
-                           (cdr (assoc prereq-rule (rule-set-rules rule-set))))
+			   (cdr (assq r (rule-set-rules rule-set))))
-                         (rule-prereqs rule))))
+			 (rule-prereqs rule))))
     (map (lambda (listen-ch)
-           (make-link connect-ch listen-ch))
+	   (make-link connect-ch listen-ch))
-         listen-chs)))
+	 listen-chs)))
-
-;;; (define (lookup-target rule rule-alist)
-;;;   (let ((maybe-targets (filter (lambda (r) (eq? (cdr r) rule)) rule-alist)))
-;;;     (if (not (null? maybe-targets))
-;;; 	(car (car maybe-targets))
-;;; 	(error "lookup-target: rule not found in rule-alist."))))
-;;; 
-;;; (define target/rule-alist '())
-;;; (define (set!-target/rule-alist alist) (set! target/rule-alist alist))
 
 (define (rule-node rule listen-ch init-state rule-set)
-  (let* ((connect-ch (send&collect/make-channel))
+  (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)
+	;; 
+	;; wait for anything on the listen-ch
+	;; check if it is a known command
+	;; if so: process this command
+	;; otherwise it was noise
+	;; 
+	;; if its the first time the make command drops in
+	;; initially make the connections to every prereq-listen-ch
+	;; 
 	(let node-loop ((tmsg (collect&reply/receive listen-ch))
-			(rcpts (get-rcpts)))
+			(?recipients #f))
-	  (cond
+	  (let ((sender (tagged-msg-tag tmsg))
-	   ((eq? (rule-cmd-name (tagged-msg-stripped tmsg)) 'make)
+		(cmd (tagged-msg-stripped tmsg)))
-	    (do-answer tmsg rcpts))
+	    (cond
-	   ((eq? (rule-cmd-name (tagged-msg-stripped tmsg)) 'shutdown)
+	     ((eq? (rule-cmd-name cmd) 'make)
-	    (terminate-current-thread))
+	      (if (not ?recipients) 
-	   (else (error "rule-node: no match")))
+		  (set! ?recipients 
-	  (node-loop (collect&reply/receive listen-ch) rcpts)))
+			(rule-node/make-links rule connect-ch rule-set)))
+	      (let ((res (rule-node/make rule listen-ch connect-ch 
+					 ?recipients init-state)))
+		(collect&reply/send listen-ch (make-tagged-msg sender res))))
+	     ((eq? (rule-cmd-name cmd) 'shutdown) (terminate-current-thread))))
+	  (node-loop (collect&reply/receive listen-ch) ?recipients)))
       'rule-node)))

make.scm

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

makefile-diplom.scm

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

makefile.scm

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

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

mcast-channels.scm

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

misc.scm

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

packages.scm

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

pkg-def.scm

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

rule-cand.scm

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

templates.scm

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

test-jobd.scm

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

test-make-rule.scm

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

test-mcast-channels.scm

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

to-rule-set.scm

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