make-rule and make-rule-no-cml work with new interface.\n\nmakros: ?prereqs can be expression

make-rule-no-cml.scm

@@ -1,38 +1,58 @@
 (define-record-type :rule
-  (really-make-rule prereqs wants-build? build-func)
+  (make-rule prereqs wants-build? build-func)
   is-rule?
   (prereqs rule-prereqs)
   (wants-build? rule-wants-build?)
   (build-func rule-build-func))
 
-(define rules (list))
+(define-record-type :rule-set
-(define lock-rules (make-lock))
+  (make-rule-set rules)
+  is-rule-set?
+ (rules rule-set-rules))
 
-(define (rule-make rule init-state)
+(define (make-empty-rule-set)
-  (let* ((res-pres (map (lambda (prereq) 
+  (make-rule-set '()))
-			  (rule-make prereq init-state))
-			(rule-prereqs rule)))
-	 (res-wants-build? (call-with-values 
-			       (lambda () 
-				 (apply values (append res-pres 
-						       (list init-state))))
-			     (rule-wants-build? rule)))
-	 (build? (car res-wants-build?))
-	 (cooked-state (cdr res-wants-build?)))
-    (if build?
-	(call-with-values 
-	    (lambda () 
-	      (apply values (append (list build?)
-				    res-pres
-				    (list cooked-state))))
-	  (rule-build-func rule))
-	res-wants-build?)))
 
-(define (make-rule prereqs wants-build? build-func)
+;;; listen-ch is a dummy here
-  (let ((rule (really-make-rule prereqs wants-build? build-func)))
+;;; now this and the one in make-rule.scm 
-    (with-lock lock-rules 
+;;; are almost the same functions
-      (lambda () 
+(define (rule-set-add rule rule-set)
-	(if (not (find (lambda (r) (eq? r rule)) rules))
+  (let ((listen-ch #f))
-	    (set! rules (cons rule rules))
+    (if (not (assq rule (rule-set-rules rule-set)))
+	(make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set)))
 	(error "make-rule: rule already exists."))))
-    rule))
+
+;;;
+;;; RULE-RESULT
+;;; 
+;;; (rule-result-wants-build? rule-result) --->  
+;;;    (wants-build?-result . cooked-state) oder (#f . cooked-state) 
+;;; 
+;;; (rule-result-build-func rule-result) --->  
+;;;    (build-func-result . end-state) oder #f 
+;;; 
+;;; (rule-make rule init-state rule-set) ---> rule-result
+;;; 
+(define-record-type :rule-result
+  (make-rule-result wants-build?-result build-func-result)
+  is-rule-result?
+  (wants-build?-result rule-result-wants-build?)
+  (build-func-result rule-result-build-func))
+
+(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 (apply (rule-wants-build? rule) 
+				     (append pre-results (list init-state))))
+	 (build-required? (car wants-build?-result))
+	 (cooked-state (cdr wants-build?-result)))
+    (if build-required?
+	(make-rule-result wants-build?-result
+			  (apply (rule-build-func rule)
+				 (append (list build-required?)
+					 pre-results 
+					 (list 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,67 @@
 	      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
+(define (rule-node/get-prereqs-results rule connect-ch recipients init-state)
+  (rule-node/sort-msgs (map 
+			(lambda (recipient)
+			  (send&collect/send connect-ch 
+					     (make-tagged-msg recipient 
 							      (rule-cmd make)))
-			       (tmsg-state (make-tagged-msg recipient 
+			  (send&collect/receive connect-ch))
-							    init-state)))
+			recipients)
-			   (send&collect/send connect-ch tmsg-cmd)
-			   (send&collect/send connect-ch tmsg-state)
-			   (send&collect/receive connect-ch)))
 		       recipients))
-	 (res-pres (rule-node/sort-msgs to-sort recipients))
+
-	 (res-build? (call-with-values
+(define (rule-node/make rule listen-ch connect-ch recipients init-state)
-			 (lambda ()
+  (let* ((prereqs-results (rule-node/get-prereqs-results rule connect-ch
-			   (apply values (append res-pres 
+							 recipients init-state))
-						 (list init-state))))
+	 (wants-build?-result (apply (rule-wants-build? rule)
-		       (rule-wants-build? rule)))
+				     (append prereqs-results (list init-state))))
-	 (res-wants-build? (car res-build?))
+	 (build-required? (car wants-build?-result))
-	 (cooked-state (cdr res-build?)))
+	 (cooked-state (cdr wants-build?-result)))
-    (if res-wants-build? 
+    (if build-required? 
-	(let ((build-res (call-with-values 
+	(make-rule-result wants-build?-result
-			     (lambda () 
+			  (apply (rule-build-func rule)
-			       (apply values (append (list res-wants-build?)
+				 (append (list build-required?)
-						     res-pres
+					 prereqs-results 
 					 (list cooked-state))))
-			   (rule-build-func rule))))
+	(make-rule-result wants-build?-result #f))))
-	  build-res)
-	(cons #t cooked-state))))
 
-(define (rule-node/recipients rule connect-ch)
+(define (rule-node/make-links rule connect-ch rule-set)
-  (let ((server-chs (map (lambda (r) 
+  (let ((listen-chs (map (lambda (r) 
-			   (with-lock lock-rules
+			   (cdr (assq r (rule-set-rules rule-set))))
-			     (lambda () 
-			       (cdr (assq r rules)))))
 			 (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,25 +1,42 @@
-(makefile
+;;; (define d (expand-file-name "~/.tmp"))
- (makefile-rule "/home/johannes/.tmp/skills.tex"
+;;; 
-		'()
+;;; (makefile
-		(lambda ()
+;;;  (makefile-rule (expand-file-name "skills.tex" d)
-		  (with-cwd "/home/johannes/.tmp"
+;;; 		()
-			    (display "Top: /home/johannes/.tmp/skills.tex"))))
+;;; 		(lambda ()
- (makefile-rule "/home/johannes/.tmp/skills.dvi"
+;;; 		  (with-cwd d (display "Top: skills.tex"))))
-		"/home/johannes/.tmp/skills.tex"
+;;;  (makefile-rule (expand-file-name "skills.dvi" d)
-		(lambda ()
+;;; 		(expand-file-name "skills.tex" d)
-		  (with-cwd "/home/johannes/.tmp"
+;;; 		(lambda ()
-			    (begin 
+;;; 		  (with-cwd d
-			      (run (latex   ,"/home/johannes/.tmp/skills.tex"))
+;;; 			    (run (latex ,(expand-file-name "skills.tex" d))))))
-			      (run (dvicopy ,"/home/johannes/.tmp/skills.dvi"
+;;;  (makefile-rule (expand-file-name "skills.pdf" d)
-					    ,"/home/johannes/.tmp/skills.dvicopy"))
+;;; 		(expand-file-name "skills.dvi" d)
-			      (rename-file "/home/johannes/.tmp/skills.dvicopy"
+;;; 		(lambda ()
-					   "/home/johannes/.tmp/skills.dvi" 
+;;; 		  (with-cwd d (run 
-					   #t)))))
+;;; 			       (dvipdfm -o 
- (makefile-rule "/home/johannes/.tmp/skills.pdf"
+;;; 					,(expand-file-name "skills.pdf" d)
-		"/home/johannes/.tmp/skills.dvi"
+;;; 					,(expand-file-name "skills.dvi" d)))))))
-		(lambda ()
+;;; 
-		  (with-cwd "/home/johannes/.tmp"
+;;; (make (expand-file-name "skills.pdf" d) "this is an empty init-state")
-			    (run (dvipdfm -o ,"/home/johannes/.tmp/skills.pdf"
+
-					  ,"/home/johannes/.tmp/skills.dvi"))))))
+(makefile
+ (makefile-rule "/home/bruegman/.tmp/skills.tex"
+		()
+		(lambda ()
+		  (with-cwd "/home/bruegman/.tmp"
+			    (display "Top: /home/bruegman/.tmp/skills.tex"))))
+ (makefile-rule "/home/bruegman/.tmp/skills.dvi"
+		("/home/bruegman/.tmp/skills.tex")
+		(lambda ()
+		  (with-cwd "/home/bruegman/.tmp"
+			    (run (latex   ,"/home/bruegman/.tmp/skills.tex")))))
+ (makefile-rule "/home/bruegman/.tmp/skills.pdf"
+		("/home/bruegman/.tmp/skills.dvi")
+		(lambda ()
+		  (with-cwd "/home/bruegman/.tmp"
+			    (run (dvipdfm -o ,"/home/bruegman/.tmp/skills.pdf"
+					  ,"/home/bruegman/.tmp/skills.dvi"))))))
+
+(make "/home/bruegman/.tmp/skills.pdf" "this is an empty init-state...")
 
-(make "/home/johannes/.tmp/skills.pdf")

makros.scm

@@ -1,22 +1,38 @@
 (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!")
+	(begin 
 	  (set! *fname->rule*-table 
-	      (alist-cons fname rule *fname->rule*-table)))))
+		(alist-cons fname rule *fname->rule*-table))
+	  (set! rule-set (rule-set-add rule rule-set))))))
+
+(define-syntax make
+  (syntax-rules ()
+    ((make ?fname ?state)
+     (rule-make (*fname->rule*-get ?fname)
+		?state
+		rule-set))))
+
+(define-syntax makefile
+  (syntax-rules () 
+    ((makefile ?rule0 ...)
+     (begin 
+       (set! rule-set (make-empty-rule-set))
+       ?rule0 ...))))
 
 (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,38 +43,76 @@
 		 ...)
 	     (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 ?target '() ?action-thunk)
+    ((makefile-rule ?target (?prereq0 ...) ?thunk)
-     (*fname->rule*-add! ?target
+     (makefile-rule-tmpvars () ?target (?prereq0 ...) ?thunk))))
-			 (make-rule '()
+
-				    (make-is-out-of-date? ?target)
+(define-syntax makefile-rule-tmpvars
-				    (lambda ?args (?action-thunk)))))
+  (syntax-rules ()
-    ((makefile-rule ?target ?prereq0 ?action-thunk)
+    ((makefile-rule-tmpvars (tmp1 ...) ?target () ?thunk)
-     (*fname->rule*-add! ?target
+     ;; 
-			 (make-rule (list (*fname->rule*-get ?prereq0))
+     ;; ?target could be an expr: eval only once
-				    (make-is-out-of-date? ?target ?prereq0)
+     ;; 
-				    (lambda ?args (?action-thunk)))))
+     (let ((target ?target))
-    ((makefile-rule ?target (?prereq0 ...) ?action-thunk)
+       (*fname->rule*-add! target
-     (begin 
+			   (make-rule (list (*fname->rule*-get tmp1)
-       (*fname->rule*-add! ?target
-			   (make-rule (list (*fname->rule*-get ?prereq0)
 					    ...)
-				      (make-is-out-of-date? ?target ?prereq0 ...)
+				      (make-is-out-of-date? target tmp1 ...)
-				      (lambda ?args (?action-thunk))))))
+				      (lambda ?args (?thunk))))))
-    ((makefile-rule (?target0 ...) ?prereqs ?action-thunk)
+    ;;
-     (begin 
+    ;; recursively construct temporary, hygienic variables
-       (makefile-rule ?target0 ?prereqs ?action-thunk)
+    ;;
-       ...))))
+    ((makefile-rule-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk)
+     (let ((tmp2 ?prereq0))
+       (makefile-rule-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk)))))
 
-(define-syntax makefile
+(define-syntax makefile-rule-md5
   (syntax-rules ()
-;    ((makefile ()) '())
+    ((makefile-rule-md5 ?fingerprint ?target (?prereq0 ...) ?thunk)
-    ((makefile ?rule0 ...) 
+     (makefile-rule-md5-tmpvars () ?fingerprint ?target (?prereq0 ...) ?thunk))))
-     (list ?rule0 ...))))
 
-(define-syntax make
+(define-syntax makefile-rule-md5-tmpvars
   (syntax-rules ()
-    ((make ?fname)
+    ((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target () ?thunk)
-     (rule-make (*fname->rule*-get ?fname)
+     ;; 
-		"This is not an empty initial state."))))
+     ;; ?target could be an expr: eval only once
+     ;; 
+     (let ((target ?target))
+       (*fname->rule*-add! target
+			   (make-rule (list (*fname->rule*-get tmp1)
+					    ...)
+				      (make-has-md5-digest=? ?fingerprint 
+							     target 
+							     tmp1 ...)
+				      (lambda ?args (?thunk))))))
+    ;;
+    ;; recursively construct temporary, hygienic variables
+    ;;
+    ((makefile-rule-md5-tmpvars (tmp1 ...) 
+				?fingerprint 
+				?target 
+				(?prereq0 ?prereq1 ...) 
+				?thunk)
+     (let ((tmp2 ?prereq0))
+       (makefile-rule-md5-tmpvars (tmp1 ... tmp2) 
+				  ?fingerprint 
+				  ?target 
+				  (?prereq1 ...) 
+				  ?thunk)))))