make-rule and make-rule-no-cml work with new interface.\n\nmakros: ?prereqs can be expression
This commit is contained in:
parent
8cb0012a99
commit
d42d574bf6
|
@ -1,38 +1,58 @@
|
||||||
(define-record-type :rule
|
(define-record-type :rule
|
||||||
(really-make-rule prereqs wants-build? build-func)
|
(make-rule prereqs wants-build? build-func)
|
||||||
is-rule?
|
is-rule?
|
||||||
(prereqs rule-prereqs)
|
(prereqs rule-prereqs)
|
||||||
(wants-build? rule-wants-build?)
|
(wants-build? rule-wants-build?)
|
||||||
(build-func rule-build-func))
|
(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)))
|
||||||
(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."))))
|
||||||
|
|
||||||
|
;;;
|
||||||
|
;;; 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))))
|
||||||
|
|
201
make-rule.scm
201
make-rule.scm
|
@ -1,16 +1,82 @@
|
||||||
;;; TODO:
|
;;;
|
||||||
;;; =====
|
;;; RULE
|
||||||
;;;
|
;;;
|
||||||
;;; o Zyklenerkennung?
|
;;; (make-rule prereqs wants-build? build-func) ---> rule
|
||||||
;;; o nicht benoetigte Threads runterfahren
|
;;;
|
||||||
|
;;; 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
|
(define-record-type :rule
|
||||||
(really-make-rule prereqs wants-build? build-func)
|
(make-rule prereqs wants-build? build-func)
|
||||||
is-rule?
|
is-rule?
|
||||||
(prereqs rule-prereqs)
|
(prereqs rule-prereqs)
|
||||||
(wants-build? rule-wants-build?)
|
(wants-build? rule-wants-build?)
|
||||||
(build-func rule-build-func))
|
(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
|
(define-enumerated-type rule-cmd :rule-cmd
|
||||||
is-rule-cmd?
|
is-rule-cmd?
|
||||||
the-rule-cmds
|
the-rule-cmds
|
||||||
|
@ -18,32 +84,6 @@
|
||||||
rule-cmd-index
|
rule-cmd-index
|
||||||
(make link shutdown))
|
(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)
|
(define (rule-node/sort-msgs unsorted to-order)
|
||||||
(map (lambda (pos)
|
(map (lambda (pos)
|
||||||
(map (lambda (tmsg)
|
(map (lambda (tmsg)
|
||||||
|
@ -54,62 +94,67 @@
|
||||||
unsorted))
|
unsorted))
|
||||||
to-order))
|
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))
|
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 (apply (rule-wants-build? rule)
|
||||||
(cdr (assq r rules)))))
|
(append prereqs-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?)
|
||||||
|
prereqs-results
|
||||||
|
(list cooked-state))))
|
||||||
|
(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))))
|
(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)))
|
(let ((connect-ch (send&collect/make-channel)))
|
||||||
(spawn
|
(spawn
|
||||||
(lambda ()
|
(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))
|
(let node-loop ((tmsg (collect&reply/receive listen-ch))
|
||||||
(recipients #f))
|
(?recipients #f))
|
||||||
(let ((sender (tagged-msg-tag tmsg))
|
(let ((sender (tagged-msg-tag tmsg))
|
||||||
(cmd (tagged-msg-stripped tmsg)))
|
(cmd (tagged-msg-stripped tmsg)))
|
||||||
(cond
|
(cond
|
||||||
((eq? (rule-cmd-name cmd) 'make)
|
((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))))
|
(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)))
|
'rule-node)))
|
||||||
|
|
65
makefile.scm
65
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")
|
|
||||||
|
|
130
makros.scm
130
makros.scm
|
@ -1,64 +1,118 @@
|
||||||
(define *fname->rule*-table '())
|
(define *fname->rule*-table '())
|
||||||
|
(define rule-set (make-empty-rule-set))
|
||||||
|
|
||||||
;;; (*fname->rule*-get fname) ---> rule
|
;;; (*fname->rule*-get fname) ---> rule
|
||||||
(define (*fname->rule*-get fname)
|
(define (*fname->rule*-get fname)
|
||||||
(let ((rule-found? (assoc fname *fname->rule*-table)))
|
(let ((rule-found? (assoc fname *fname->rule*-table)))
|
||||||
(if rule-found?
|
(if rule-found? (cdr rule-found?))))
|
||||||
(cdr rule-found?))))
|
|
||||||
|
|
||||||
;;; (*fname->rule*-add! fname) ---> {}
|
;;; (*fname->rule*-add! fname) ---> {}
|
||||||
(define (*fname->rule*-add! fname rule)
|
(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?
|
(if rule-found?
|
||||||
(error "There already exists a rule with this fname!")
|
(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
|
||||||
|
(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?
|
(define-syntax make-is-out-of-date?
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((make-is-out-of-date? ?target '())
|
((make-is-out-of-date? ?target)
|
||||||
(lambda ?args
|
(lambda ?args
|
||||||
(cons (file-not-exists? ?target) ?args)))
|
(cons (file-not-exists? ?target) ?args)))
|
||||||
((make-is-out-of-date? ?target ?prereq0 ...)
|
((make-is-out-of-date? ?target ?prereq0 ...)
|
||||||
(lambda ?args
|
(lambda ?args
|
||||||
(cons (or (file-not-exists? ?target)
|
(cons (or (file-not-exists? ?target)
|
||||||
(> (file-last-mod ?prereq0)
|
(> (file-last-mod ?prereq0)
|
||||||
(file-last-mod ?target))
|
(file-last-mod ?target))
|
||||||
...)
|
...)
|
||||||
(last ?args))))))
|
(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
|
(define-syntax makefile-rule
|
||||||
(syntax-rules ()
|
(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)
|
|
||||||
(lambda ?args (?action-thunk)))))
|
|
||||||
((makefile-rule ?target ?prereq0 ?action-thunk)
|
|
||||||
(*fname->rule*-add! ?target
|
|
||||||
(make-rule (list (*fname->rule*-get ?prereq0))
|
|
||||||
(make-is-out-of-date? ?target ?prereq0)
|
|
||||||
(lambda ?args (?action-thunk)))))
|
|
||||||
((makefile-rule ?target (?prereq0 ...) ?action-thunk)
|
|
||||||
(begin
|
|
||||||
(*fname->rule*-add! ?target
|
|
||||||
(make-rule (list (*fname->rule*-get ?prereq0)
|
|
||||||
...)
|
|
||||||
(make-is-out-of-date? ?target ?prereq0 ...)
|
|
||||||
(lambda ?args (?action-thunk))))))
|
|
||||||
((makefile-rule (?target0 ...) ?prereqs ?action-thunk)
|
|
||||||
(begin
|
|
||||||
(makefile-rule ?target0 ?prereqs ?action-thunk)
|
|
||||||
...))))
|
|
||||||
|
|
||||||
(define-syntax makefile
|
(define-syntax makefile-rule-tmpvars
|
||||||
(syntax-rules ()
|
|
||||||
; ((makefile ()) '())
|
|
||||||
((makefile ?rule0 ...)
|
|
||||||
(list ?rule0 ...))))
|
|
||||||
|
|
||||||
(define-syntax make
|
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((make ?fname)
|
((makefile-rule-tmpvars (tmp1 ...) ?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-is-out-of-date? target tmp1 ...)
|
||||||
|
(lambda ?args (?thunk))))))
|
||||||
|
;;
|
||||||
|
;; recursively construct temporary, hygienic variables
|
||||||
|
;;
|
||||||
|
((makefile-rule-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk)
|
||||||
|
(let ((tmp2 ?prereq0))
|
||||||
|
(makefile-rule-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk)))))
|
||||||
|
|
||||||
|
(define-syntax makefile-rule-md5
|
||||||
|
(syntax-rules ()
|
||||||
|
((makefile-rule-md5 ?fingerprint ?target (?prereq0 ...) ?thunk)
|
||||||
|
(makefile-rule-md5-tmpvars () ?fingerprint ?target (?prereq0 ...) ?thunk))))
|
||||||
|
|
||||||
|
(define-syntax makefile-rule-md5-tmpvars
|
||||||
|
(syntax-rules ()
|
||||||
|
((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target () ?thunk)
|
||||||
|
;;
|
||||||
|
;; ?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)))))
|
||||||
|
|
Loading…
Reference in New Issue