make-rule and make-rule-no-cml work with new interface.\n\nmakros: ?prereqs can be expression
This commit is contained in:
jottbee
parent
8cb0012a99
commit
d42d574bf6
|
|
@ -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 lock-rules (make-lock))
|
||||
(define-record-type :rule-set
|
||||
(make-rule-set rules)
|
||||
is-rule-set?
|
||||
(rules rule-set-rules))
|
||||
|
||||
(define (rule-make rule init-state)
|
||||
(let* ((res-pres (map (lambda (prereq)
|
||||
(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-empty-rule-set)
|
||||
(make-rule-set '()))
|
||||
|
||||
(define (make-rule prereqs wants-build? build-func)
|
||||
(let ((rule (really-make-rule prereqs wants-build? build-func)))
|
||||
(with-lock lock-rules
|
||||
(lambda ()
|
||||
(if (not (find (lambda (r) (eq? r rule)) rules))
|
||||
(set! rules (cons rule rules))
|
||||
(error "make-rule: rule already exists."))))
|
||||
rule))
|
||||
;;; listen-ch is a dummy here
|
||||
;;; now this and the one in make-rule.scm
|
||||
;;; 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)))
|
||||
(make-rule-set (alist-cons rule listen-ch (rule-set-rules rule-set)))
|
||||
(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:
|
||||
;;; =====
|
||||
;;;
|
||||
;;; o Zyklenerkennung?
|
||||
;;; o nicht benoetigte Threads runterfahren
|
||||
|
||||
;;;
|
||||
;;; RULE
|
||||
;;;
|
||||
;;; (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)
|
||||
(let* ((to-sort (map (lambda (recipient)
|
||||
(let ((tmsg-cmd (make-tagged-msg recipient
|
||||
(rule-cmd make)))
|
||||
(tmsg-state (make-tagged-msg recipient
|
||||
init-state)))
|
||||
(send&collect/send connect-ch tmsg-cmd)
|
||||
(send&collect/send connect-ch tmsg-state)
|
||||
(send&collect/receive connect-ch)))
|
||||
;;; send each prereq-thread a make command and the init-state
|
||||
;;; then wait for the results to return
|
||||
;;; 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)))
|
||||
(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)
|
||||
(let ((server-chs (map (lambda (r)
|
||||
(with-lock lock-rules
|
||||
(lambda ()
|
||||
(cdr (assq r rules)))))
|
||||
(define (rule-node/make rule listen-ch connect-ch recipients init-state)
|
||||
(let* ((prereqs-results (rule-node/get-prereqs-results rule connect-ch
|
||||
recipients init-state))
|
||||
(wants-build?-result (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?
|
||||
(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))))
|
||||
(map (lambda (server-ch)
|
||||
(make-link connect-ch server-ch))
|
||||
server-chs)))
|
||||
(map (lambda (listen-ch)
|
||||
(make-link connect-ch listen-ch))
|
||||
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)
|
||||
(set! recipients (rule-node/recipients rule connect-ch)))
|
||||
(let* ((tmsg (collect&reply/receive listen-ch))
|
||||
(init-state (tagged-msg-stripped tmsg))
|
||||
(res (rule-node/make rule recipients
|
||||
connect-ch listen-ch init-state)))
|
||||
(if (not ?recipients)
|
||||
(set! ?recipients
|
||||
(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)))
|
||||
((eq? (rule-cmd-name cmd) 'shutdown) (terminate-current-thread))))
|
||||
(node-loop (collect&reply/receive listen-ch) ?recipients)))
|
||||
'rule-node)))
|
||||
|
|
|
|||
65
makefile.scm
65
makefile.scm
|
|
@ -1,25 +1,42 @@
|
|||
(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"
|
||||
(begin
|
||||
(run (latex ,"/home/johannes/.tmp/skills.tex"))
|
||||
(run (dvicopy ,"/home/johannes/.tmp/skills.dvi"
|
||||
,"/home/johannes/.tmp/skills.dvicopy"))
|
||||
(rename-file "/home/johannes/.tmp/skills.dvicopy"
|
||||
"/home/johannes/.tmp/skills.dvi"
|
||||
#t)))))
|
||||
(makefile-rule "/home/johannes/.tmp/skills.pdf"
|
||||
"/home/johannes/.tmp/skills.dvi"
|
||||
(lambda ()
|
||||
(with-cwd "/home/johannes/.tmp"
|
||||
(run (dvipdfm -o ,"/home/johannes/.tmp/skills.pdf"
|
||||
,"/home/johannes/.tmp/skills.dvi"))))))
|
||||
;;; (define d (expand-file-name "~/.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) "this is an empty init-state")
|
||||
|
||||
(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 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?))))
|
||||
(if 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
|
||||
(alist-cons fname rule *fname->rule*-table)))))
|
||||
(begin
|
||||
(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?
|
||||
(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 ...)
|
||||
(lambda ?args
|
||||
(cons (or (file-not-exists? ?target)
|
||||
(> (file-last-mod ?prereq0)
|
||||
(> (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 ?target '() ?action-thunk)
|
||||
(*fname->rule*-add! ?target
|
||||
(make-rule '()
|
||||
(make-is-out-of-date? ?target)
|
||||
(lambda ?args (?action-thunk)))))
|
||||
((makefile-rule ?target ?prereq0 ?action-thunk)
|
||||
(*fname->rule*-add! ?target
|
||||
(make-rule (list (*fname->rule*-get ?prereq0))
|
||||
(make-is-out-of-date? ?target ?prereq0)
|
||||
(lambda ?args (?action-thunk)))))
|
||||
((makefile-rule ?target (?prereq0 ...) ?action-thunk)
|
||||
(begin
|
||||
(*fname->rule*-add! ?target
|
||||
(make-rule (list (*fname->rule*-get ?prereq0)
|
||||
...)
|
||||
(make-is-out-of-date? ?target ?prereq0 ...)
|
||||
(lambda ?args (?action-thunk))))))
|
||||
((makefile-rule (?target0 ...) ?prereqs ?action-thunk)
|
||||
(begin
|
||||
(makefile-rule ?target0 ?prereqs ?action-thunk)
|
||||
...))))
|
||||
((makefile-rule ?target (?prereq0 ...) ?thunk)
|
||||
(makefile-rule-tmpvars () ?target (?prereq0 ...) ?thunk))))
|
||||
|
||||
(define-syntax makefile
|
||||
(syntax-rules ()
|
||||
; ((makefile ()) '())
|
||||
((makefile ?rule0 ...)
|
||||
(list ?rule0 ...))))
|
||||
|
||||
(define-syntax make
|
||||
(define-syntax makefile-rule-tmpvars
|
||||
(syntax-rules ()
|
||||
((make ?fname)
|
||||
(rule-make (*fname->rule*-get ?fname)
|
||||
"This is not an empty initial state."))))
|
||||
((makefile-rule-tmpvars (tmp1 ...) ?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-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