Initial import.

cml-pe.scm

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

job.scm

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

jobd.scm

@@ -0,0 +1,116 @@
+(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))
+
+(define-enumerated-type jobber-sig :jobber-sig
+  jobber-sig?
+  the-jobber-sigs
+  jobber-sig-name
+  jobber-sig-index
+  (shutdown stop continue))
+
+(define (cml-fork-collecting->rv id job-desc sig-ch)
+  (let* ((ch (cml-sync-ch/make-channel))
+	 (cwd (job-desc-wd job-desc))
+	 (env (job-desc-env job-desc))
+	 (cmd (job-desc-cmd job-desc))
+	 (fds (list 1 2))
+	 (thunk (lambda () (with-total-env ,env (with-cwd cwd cmd))))
+	 (res-rv (cml-fork-collecting fds sig-ch thunk)))
+    (spawn 
+      (lambda ()
+	(let ((results (cml-rv/sync res-rv)))
+	  (cml-sync-ch/send ch (make-job-res (list-ref results 0)
+                                             (list-ref results 1)
+                                             (list-ref results 2)))))
+      (format #t "cml-fork-collecting->rv (no. ~a)\n" id))
+    (cml-sync-ch/receive-rv ch)))
+
+;;; ->alist?
+(define (jobber-sig->signal sig to-process-element)
+  (cond 
+   ((jobber-sig? sig)
+    (cond 
+     ((eq? (jobber-sig-name sig) 'shutdown) 
+	  (cml-sync-ch/send to-process-element signal/kill))
+     ((eq? (jobber-sig-name sig) 'stop) 
+	  (cml-sync-ch/send to-process-element signal/stop))
+     ((eq? (jobber-sig-name sig) 'continue) 
+	  (cml-sync-ch/send to-process-element signal/cont))
+     (else (error "jobber: jobber-sig->signal received unknown jobber-sig."))))
+   (else (error "jobber: jobber-sig->signal received unknown object."))))
+
+(define (job-desc->job-res id sig-mport j-des+res-ch)
+  (let* ((j-des (car j-des+res-ch))
+	 (res-ch (cdr j-des+res-ch))
+	 (to-process-element (cml-sync-ch/make-channel))
+	 (sig-rcv-rv (cml-mcast-ch/mcast-port-receive-rv sig-mport))
+	 (job-res-rv (cml-fork-collecting->rv id j-des to-process-element)))
+    (let finish-job ()
+      (cml-rv/select 
+       (cml-rv/wrap sig-rcv-rv
+		    (lambda (sig) 
+		      (jobber-sig->signal sig to-process-element)
+		      (finish-job)))
+       (cml-rv/wrap job-res-rv
+		    (lambda (res) 
+		      (cml-async-ch/send-async res-ch res)))))))
+
+(define (jobber id job-ch sig-mport)
+  (spawn 
+    (lambda () 
+      (let loop ()
+	(let ((new-job-rv (cml-async-ch/receive-async-rv job-ch))
+	      (sig-rcv-rv (cml-mcast-ch/mcast-port-receive-rv sig-mport)))
+	  (cml-rv/select 
+	   (cml-rv/wrap new-job-rv
+			(lambda (j-des+res-ch) 
+			  (job-desc->job-res id sig-mport j-des+res-ch)))
+	   (cml-rv/wrap sig-rcv-rv
+			(lambda (sig) 
+			  (if (eq? (jobber-sig-name sig) 'shutdown) 
+			      (terminate-current-thread)))))
+	   (loop))))
+    (format #t "jobber (no. ~a)\n" id)))
+
+(define jobd-vers "jobd-0.0.1")
+
+(define (make-jobd)
+  (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) 
+			 (jobber id job-ch (cml-mcast-ch/mcast-port sig-m-ch)))))
+    (for-each start-jobber (enumerate jobbers))
+    (really-make-jobd version job-ch sig-m-ch)))
+
+(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 (shutdown jobd)
+  (cml-mcast-ch/mcast (jobd-sig-mc jobd) (jobber-sig shutdown)))
+
+(define (stop jobd)
+  (cml-mcast-ch/mcast (jobd-sig-mc jobd) (jobber-sig stop)))
+
+(define (continue jobd)
+  (cml-mcast-ch/mcast (jobd-sig-mc jobd) (jobber-sig continue)))
+
+(define (enumerate n-max)
+  (cond 
+   ((> n-max 1) (append (enumerate (- n-max 1)) (list n-max)))
+   ((= n-max 1) (list n-max))
+   (else (error "n-max < 0"))))
+
+(define jobbers 2)
+
+(define (set-jobbers! n-of)
+  (set! jobbers n-of))

make-rule-no-cml.scm

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

make-rule.scm

@@ -1,16 +1,82 @@
-;;;   TODO:
-;;;   =====
 ;;;
-;;;    o  Zyklenerkennung?
+;;; RULE
-;;;    o  nicht benoetigte Threads runterfahren
+;;;
-
+;;; (make-rule prereqs wants-build? build-func) ---> rule
+;;;
+;;; prereqs: '(#{:rule} ...)
+;;; wants-build?: (lambda (res-p0 res-p1 ... res-pN init-state) body ...)
+;;;               res-pX: result of prerequisite-rule no. X
+;;;   (wants-build? res-p0 ... res-pN init-state) 
+;;;      ---> (res-wants-build? . cooked-state)
+;;; build-func: 
+;;;   (lambda (res-wants-build? res-p0 ... res-pN cooked-state) 
+;;;      ---> (res-build-func . end-state)
+;;;
 (define-record-type :rule
-  (really-make-rule prereqs wants-build? build-func)
+  (make-rule prereqs wants-build? build-func)
   is-rule?
   (prereqs rule-prereqs)
   (wants-build? rule-wants-build?)
   (build-func rule-build-func))
 
+;;;
+;;; RULE-SET
+;;;
+;;; (make-empty-rule-set) ---> rule-set
+;;; (rule-set-add! rule rule-set) ---> rule-set
+;;;
+(define-record-type :rule-set
+  (make-rule-set rules)
+  is-rule-set?
+ (rules rule-set-rules))
+
+(define (make-empty-rule-set) 
+  (make-rule-set '()))
+
+(define (rule-set-add rule rule-set)
+  (let ((listen-ch (collect&reply/make-channel)))
+    (if (not (assq rule (rule-set-rules rule-set)))
+	(make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set)))
+	(error "make-rule: rule already exists."))))
+
+(define (rule-set-get-listen-ch rule rule-set)
+  (let ((?thing (assq rule (rule-set-rules rule-set))))
+    (if (and ?thing (pair? ?thing) (is-collect&reply-channel? (cdr ?thing)))
+	(cdr ?thing)
+	(error "Rule not found in rule-set."))))
+
+;;;
+;;; RULE-RESULT
+;;; 
+;;; (rule-result-wants-build? rule-result) --->  
+;;;    (wants-build?-result . cooked-state) oder (#f . cooked-state) 
+;;; 
+;;; (rule-result-build-func rule-result) --->  
+;;;    (build-func-result . end-state) oder #f 
+;;; 
+;;; (rule-make rule init-state rule-set) ---> rule-result
+;;; 
+(define-record-type :rule-result
+  (make-rule-result wants-build?-result build-func-result)
+  is-rule-result?
+  (wants-build?-result rule-result-wants-build?)
+  (build-func-result rule-result-build-func))
+
+(define (rule-make rule init-state rule-set)
+  ;;
+  ;; this could be rewritten in future
+  ;; 
+  ;; check for unused threads -> dont start them
+  ;;
+  (map (lambda (r) 
+	 (rule-node r (rule-set-get-listen-ch r rule-set) init-state rule-set))
+       (map car (rule-set-rules rule-set)))
+  (let* ((server (rule-set-get-listen-ch rule rule-set))
+	 (client (send&collect/make-channel))
+	 (recipient (make-link client server)))
+    (send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
+    (tagged-msg-stripped (send&collect/receive client))))
+
 (define-enumerated-type rule-cmd :rule-cmd
   is-rule-cmd?
   the-rule-cmds
@@ -18,32 +84,6 @@
   rule-cmd-index
   (make link shutdown))
 
-(define (rule-make rule init-state)
-  (let* ((server (let ((found? (assq rule rules)))
-		   (if (is-collect&reply-channel? (cdr found?)) 
-		       (cdr found?) 
-		       (error "rule-make: rule not found."))))
-	 (client (send&collect/make-channel))
-	 (recipient (make-link client server)))
-    (send&collect/send client (make-tagged-msg recipient (rule-cmd make)))
-    (send&collect/send client (make-tagged-msg recipient init-state))
-    (tagged-msg-stripped (send&collect/receive client))))
-
-(define rules (list))
-(define lock-rules (make-lock))
-
-(define (make-rule prereqs wants-build? build-func)
-  (let ((rule (really-make-rule prereqs wants-build? build-func))
-	(listen-ch (collect&reply/make-channel)))
-    (with-lock lock-rules 
-      (lambda () 
-	(if (not (assq rule rules))
-	    (begin 
-	      (set! rules (alist-cons rule listen-ch rules))
-	      (rule-node rule listen-ch))
-	    (error "make-rule: rule already exists."))))
-    rule))
-
 (define (rule-node/sort-msgs unsorted to-order)
   (map (lambda (pos)
 	 (map (lambda (tmsg)
@@ -54,62 +94,72 @@
 	      unsorted))
        to-order))
 
-(define (rule-node/make rule recipients connect-ch listen-ch init-state)
+;;; send each prereq-thread a make command and the init-state
-  (let* ((to-sort (map (lambda (recipient)
+;;; then wait for the results to return 
-			 (let ((tmsg-cmd (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)
-			       (tmsg-state (make-tagged-msg recipient 
+  (rule-node/sort-msgs (map 
-							    init-state)))
+			(lambda (recipient)
-			   (send&collect/send connect-ch tmsg-cmd)
+			  (send&collect/send connect-ch 
-			   (send&collect/send connect-ch tmsg-state)
+					     (make-tagged-msg recipient 
-			   (send&collect/receive connect-ch)))
+							      (rule-cmd make)))
+			  (send&collect/receive connect-ch))
+			recipients)
 		       recipients))
-	 (res-pres (rule-node/sort-msgs to-sort recipients))
-	 (res-build? (call-with-values
-			 (lambda ()
-			   (apply values (append res-pres 
-						 (list init-state))))
-		       (rule-wants-build? rule)))
-	 (res-wants-build? (car res-build?))
-	 (cooked-state (cdr res-build?)))
-    (if res-wants-build? 
-	(let ((build-res (call-with-values 
-			     (lambda () 
-			       (apply values (append (list res-wants-build?)
-						     res-pres
-						     (list cooked-state))))
-			   (rule-build-func rule))))
-	  build-res)
-	(cons #t cooked-state))))
 
-(define (rule-node/recipients rule connect-ch)
+(define (rule-node/make rule listen-ch connect-ch recipients init-state)
-  (let ((server-chs (map (lambda (r) 
+  (let* ((prereqs-results (rule-node/get-prereqs-results rule connect-ch
-			   (with-lock lock-rules
+							 recipients init-state))
-			     (lambda () 
+	 (wants-build?-result (call-with-values
-			       (cdr (assq r rules)))))
+				  (lambda ()
+				    (apply values (append prereqs-results
+							  (list init-state))))
+				(rule-wants-build? rule)))
+	 (build-required? (car wants-build?-result))
+	 (cooked-state (cdr wants-build?-result)))
+    (if build-required? 
+	(make-rule-result wants-build?-result
+			  (call-with-values 
+			      (lambda () 
+				(apply values (append (list build-required?)
+						      prereqs-results 
+						      (list cooked-state))))
+			    (rule-build-func rule)))
+	(make-rule-result wants-build?-result #f))))
+
+(define (rule-node/make-links rule connect-ch rule-set)
+  (let ((listen-chs (map (lambda (r) 
+			   (cdr (assq r (rule-set-rules rule-set))))
 			 (rule-prereqs rule))))
-    (map (lambda (server-ch)
+    (map (lambda (listen-ch)
-	   (make-link connect-ch server-ch))
+	   (make-link connect-ch listen-ch))
-	 server-chs)))
+	 listen-chs)))
 
-(define (rule-node rule listen-ch)
+(define (rule-node rule listen-ch init-state rule-set)
   (let ((connect-ch (send&collect/make-channel)))
     (spawn
       (lambda () 
+	;; 
+	;; wait for anything on the listen-ch
+	;; check if it is a known command
+	;; if so: process this command
+	;; otherwise it was noise
+	;; 
+	;; if its the first time the make command drops in
+	;; initially make the connections to every prereq-listen-ch
+	;; 
 	(let node-loop ((tmsg (collect&reply/receive listen-ch))
-			(recipients #f))
+			(?recipients #f))
 	  (let ((sender (tagged-msg-tag tmsg))
 		(cmd (tagged-msg-stripped tmsg)))
 	    (cond
 	     ((eq? (rule-cmd-name cmd) 'make)
-	      (if (not recipients) 
+	      (if (not ?recipients) 
-		  (set! recipients (rule-node/recipients rule connect-ch)))
+		  (set! ?recipients 
-	      (let* ((tmsg (collect&reply/receive listen-ch))
+			(rule-node/make-links rule connect-ch rule-set)))
-		     (init-state (tagged-msg-stripped tmsg))
+	      (let ((res (rule-node/make rule listen-ch connect-ch 
-		     (res (rule-node/make rule recipients
+					 ?recipients init-state)))
-					    connect-ch listen-ch init-state)))
 		(collect&reply/send listen-ch (make-tagged-msg sender res))))
-	     ((eq? (rule-cmd-name cmd) 'shutdown)
+	     ((eq? (rule-cmd-name cmd) 'shutdown) (terminate-current-thread))))
-	      (terminate-current-thread))))
+	  (node-loop (collect&reply/receive listen-ch) ?recipients)))
-	  (node-loop (collect&reply/receive listen-ch) recipients)))
       'rule-node)))

makefile.scm

@@ -1,3 +1,25 @@
+;; (define d "~/.tmp")
+;; 
+;; (makefile
+;;  (makefile-rule (expand-file-name "skills.tex" d)
+;; 		'()
+;; 		(lambda ()
+;; 		  (with-cwd d (display "Top: skills.tex"))))
+;;  (makefile-rule (expand-file-name "skills.dvi" d)
+;; 		(expand-file-name "skills.tex" d)
+;; 		(lambda ()
+;; 		  (with-cwd d
+;; 			    (run (latex ,(expand-file-name "skills.tex" d))))))
+;;  (makefile-rule (expand-file-name "skills.pdf" d)
+;; 		(expand-file-name "skills.dvi" d)
+;; 		(lambda ()
+;; 		  (with-cwd d (run 
+;; 			       (dvipdfm -o 
+;; 					,(expand-file-name "skills.pdf" d)
+;; 					,(expand-file-name "skills.dvi" d)))))))
+;; 
+;; (make (expand-file-name "skills.pdf" d))
+
 (makefile
  (makefile-rule "/home/johannes/.tmp/skills.tex"
 		'()
@@ -8,13 +30,7 @@
 		"/home/johannes/.tmp/skills.tex"
 		(lambda ()
 		  (with-cwd "/home/johannes/.tmp"
-			    (begin 
+			    (run (latex   ,"/home/johannes/.tmp/skills.tex")))))
-			      (run (latex   ,"/home/johannes/.tmp/skills.tex"))
-			      (run (dvicopy ,"/home/johannes/.tmp/skills.dvi"
-					    ,"/home/johannes/.tmp/skills.dvicopy"))
-			      (rename-file "/home/johannes/.tmp/skills.dvicopy"
-					   "/home/johannes/.tmp/skills.dvi" 
-					   #t)))))
  (makefile-rule "/home/johannes/.tmp/skills.pdf"
 		"/home/johannes/.tmp/skills.dvi"
 		(lambda ()
@@ -23,3 +39,4 @@
 					  ,"/home/johannes/.tmp/skills.dvi"))))))
 
 (make "/home/johannes/.tmp/skills.pdf")
+

makros.scm

@@ -1,22 +1,24 @@
 (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? 
+    (if rule-found? (cdr rule-found?))))
-	(cdr rule-found?))))
 
 ;;; (*fname->rule*-add! fname) ---> {}
 (define (*fname->rule*-add! fname rule)
-  (let ((rule-found? (assq fname *fname->rule*-table)))
+  (let ((rule-found? (assoc fname *fname->rule*-table)))
     (if rule-found?
 	(error "There already exists a rule with this fname!")
-	(set! *fname->rule*-table 
+	(begin 
-	      (alist-cons fname rule *fname->rule*-table)))))
+	  (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 '())
+    ((make-is-out-of-date? ?target)
      (lambda ?args
        (cons (file-not-exists? ?target) ?args)))
     ((make-is-out-of-date? ?target ?prereq0 ...)
@@ -27,18 +29,35 @@
 		 ...)
 	     (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)
-     (*fname->rule*-add! ?target
-			 (make-rule (list (*fname->rule*-get ?prereq0))
-				    (make-is-out-of-date? ?target ?prereq0)
-				    (lambda ?args (?action-thunk)))))
     ((makefile-rule ?target (?prereq0 ...) ?action-thunk)
      (begin 
        (*fname->rule*-add! ?target
@@ -46,19 +65,27 @@
 					    ...)
 				      (make-is-out-of-date? ?target ?prereq0 ...)
 				      (lambda ?args (?action-thunk))))))
-    ((makefile-rule (?target0 ...) ?prereqs ?action-thunk)
+    ((makefile-rule ?target ?prereq0 ?action-thunk)
-     (begin 
+     (*fname->rule*-add! ?target
-       (makefile-rule ?target0 ?prereqs ?action-thunk)
+			 (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 ...)
-     (list ?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."))))
+		"This is not an empty initial state."
+		rule-set))))

packages.scm

@@ -1,3 +1,104 @@
+(define-interface jobd-interface
+  (export make-jobd
+	  jobd?
+	  version
+	  execute
+	  stop
+	  continue
+	  shutdown
+	  set-jobbers!))
+
+(define-structure jobd jobd-interface
+  (open scheme-with-scsh
+	formats
+	srfi-1
+	(with-prefix srfi-8 srfi-8/)
+	srfi-9
+	srfi-11
+	threads
+	threads-internal
+	(with-prefix rendezvous cml-rv/)
+	(with-prefix mcast-channels cml-mcast-ch/)
+	(with-prefix rendezvous-channels cml-sync-ch/)
+	(with-prefix rendezvous-async-channels cml-async-ch/)
+	finite-types
+	job
+	cml-pe)
+  (files jobd))
+
+(define-interface cml-pe-interface
+  (export cml-fork
+	  cml-fork-collecting))
+
+(define-structure cml-pe cml-pe-interface
+  (open scheme-with-scsh
+	srfi-9
+	threads
+        (with-prefix rendezvous cml-rv/)
+	(with-prefix rendezvous-channels cml-sync-ch/))
+  (files cml-pe))
+
+(define-interface mcast-channels-interface
+  (export make-mcast-channel
+	  mcast-channel?
+	  mcast-port?
+	  mcast
+	  mcast-port
+	  mcast-port-receive
+	  mcast-port-receive-rv))
+
+(define-structure mcast-channels mcast-channels-interface
+  (open scheme
+        srfi-9
+        threads
+	finite-types
+        rendezvous
+        rendezvous-channels)
+  (files mcast-channels))
+
+(define-interface job-interface
+  (export make-job-desc
+	  job-desc?
+	  job-desc-wd
+	  job-desc-env
+	  job-desc-cmd
+	  make-job-res
+	  job-res?
+	  job-res-errno
+	  job-res-stdout
+	  job-res-stderr
+	  display-job-output))
+
+(define-structure job job-interface
+  (open scheme-with-scsh
+	srfi-9)
+  (files job))
+
+(define-structure test-jobd
+  (export do-some-jobs)
+  (open scheme-with-scsh
+	locks
+	threads
+	threads-internal
+	srfi-1
+	(with-prefix rendezvous cml-rv/)
+	(with-prefix rendezvous-channels cml-sync-ch/)
+	(with-prefix rendezvous-async-channels cml-async-ch/)
+	cml-pe
+	job
+	(with-prefix jobd jobd/))
+  (files test-jobd))
+
+(define-structure test-mcast-channels 
+  (export test-it)
+  (open scheme
+	srfi-9
+	threads
+	rendezvous
+	rendezvous-channels
+	mcast-channels)
+  (files test-mcast-channels))
+
 (define-interface collect-channels-interface
   (export make-tagged-msg
 	  is-tagged-msg?
@@ -30,9 +131,11 @@
 (define-interface make-rule-interface
   (export make-rule
 	  is-rule?
-	  rule-prereqs
+	  make-empty-rule-set
-	  rule-wants-build?
+	  rule-set-add
-	  rule-build-func
+	  is-rule-set?
+	  make-rule-result
+	  is-rule-result?
 	  rule-make))
 
 (define-structure make-rule make-rule-interface
@@ -51,9 +154,11 @@
 (define-interface make-rule-no-cml-interface
   (export make-rule
 	  is-rule?
-	  rule-prereqs
+	  make-empty-rule-set
-	  rule-wants-build?
+	  rule-set-add
-	  rule-build-func
+	  is-rule-set?
+	  make-rule-result
+	  is-rule-result?
 	  rule-make))
 
 (define-structure make-rule-no-cml make-rule-no-cml-interface
@@ -73,5 +178,5 @@
 (define-structure makros makros-interface
   (open scheme-with-scsh
 	srfi-1
-	make-rule)
+	make-rule-no-cml)
   (files makros))