scsh-conservatory
/
scsh-make
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added common rules: (common-file "%.o" ("%.c" "%.h") ...)

This commit is contained in:
jottbee 2005-02-24 14:30:07 +00:00
parent 6fe70b47e3
commit 0898ffd43d
7 changed files with 536 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
autovars.scm
View File

@ -4,10 +4,13 @@
(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 fluid-$^/ (make-preserved-thread-fluid (list))) (define fluid-$^/ (make-preserved-thread-fluid (list)))
@ -17,6 +20,21 @@
(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-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) (define (bind-fluids-gnu target prereqs prereqs-results thunk)
(let (($@ target) (let (($@ target)
($< (cond ($< (cond
@ -59,9 +77,7 @@
newer-prereqs))))) newer-prereqs)))))
(else (error "no match in bind-fluids-gnu fluid-$?")))) (else (error "no match in bind-fluids-gnu fluid-$?"))))
($^ (delete-duplicates! prereqs)) ($^ (delete-duplicates! prereqs))
($+ prereqs) ($+ prereqs))
($* ""))
(let-thread-fluids fluid-$@ $@ ;; $@ : file name of the target (let-thread-fluids fluid-$@ $@ ;; $@ : file name of the target
;; $% : target member name, when target is an archive member. ;; $% : target member name, when target is an archive member.
;; fluid-$% target ;; fluid-$% target
@ -77,9 +93,6 @@
fluid-$^ $^ fluid-$^ $^
fluid-$+ $+ fluid-$+ $+
;; $* : The stem with which an implicit rule matches.
fluid-$* $*
;; we have no parens so we will use the following *scheme*: ;; we have no parens so we will use the following *scheme*:
;; e.g. for $@: $@/ denotes directory part of $@ ;; e.g. for $@: $@/ denotes directory part of $@
;; while /$@ denotes file within directory of $@ ;; while /$@ denotes file within directory of $@
@ -88,10 +101,6 @@
fluid-$@/ (file-name-directory $@) fluid-$@/ (file-name-directory $@)
fluid-/$@ (file-name-nondirectory $@) fluid-/$@ (file-name-nondirectory $@)
;; $(*D), $(*F) : directory part and file-within-directory
fluid-$*/ (file-name-directory $*)
fluid-/$* (file-name-nondirectory $*)
;; $(%D), $(%F) : directory part and file-within-directory ;; $(%D), $(%F) : directory part and file-within-directory
; $%/ (file-name-directory fluid-$%) ; $%/ (file-name-directory fluid-$%)
; /$% (file-name-nondirectory fluid-$%) ; /$% (file-name-nondirectory fluid-$%)
@ -132,10 +141,13 @@
(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 ($^/) (thread-fluid fluid-$^/)) (define ($^/) (thread-fluid fluid-$^/))

139
common-rules.scm Normal file
View File

@ -0,0 +1,139 @@
(define-record-type :common-rule
(really-make-common-rule target prereqs wants-build? build-func)
is-common-rule?
(target common-rule-target)
(prereqs common-rule-prereqs)
(wants-build? common-rule-wants-build?)
(build-func common-rule-build-func))
(define (make-empty-common-rules)
(let* ((target-pattern "%")
(make-does-file-exist? (lambda (target-name . cooked-prereqs)
(lambda args
(cons (file-not-exists? target-name)
(last args)))))
(make-error-if-not-exists (lambda (target-name . cooked-prereqs)
(lambda args
(error "file (assumed leaf) does not exist:"
target-name))))
(common-rule (really-make-common-rule target-pattern
(list)
make-does-file-exist?
make-error-if-not-exists)))
(list common-rule)))
(define (common-rules-add common-rules descr)
(let ((target (list-ref descr 0))
(prereqs (list-ref descr 1))
(wants-build? (list-ref descr 2))
(build-func (list-ref descr 3)))
(cons (really-make-common-rule target prereqs wants-build? build-func)
common-rules)))
(define (search-match-in-common-rules common-rules target)
(if (null? common-rules)
#f
(let next-common-rule ((current (car common-rules))
(todo (cdr common-rules)))
(let ((maybe-target (is-matched-by? (common-rule-target current) target)))
(if maybe-target
(let* ((prefix (list-ref maybe-target 0))
(match (list-ref maybe-target 1))
(suffix (list-ref maybe-target 2))
(target-name (string-append prefix match suffix))
(cooked-prereqs (map (lambda (prereq)
(replace-by-match prereq match))
(common-rule-prereqs current)))
(make-wants-build? (common-rule-wants-build? current))
(wants-build? (apply make-wants-build?
(append (list target-name)
cooked-prereqs)))
(make-build-func (common-rule-build-func current))
(build-func
(lambda args
(bind-fluids-common target-name prefix match suffix
(lambda ()
(apply
(make-build-func target-name
cooked-prereqs)
args))))))
(list target-name cooked-prereqs wants-build? build-func))
(if (null? todo)
#f
(next-common-rule (car todo) (cdr todo))))))))
(define (common-rcs->common-rules common-rules)
(let ((empty-rules (make-empty-common-rules))
(common-rcs common-rules)) ; maybe reverse list
(if (null? common-rcs)
empty-rules
(let each-rc ((rc (car common-rcs))
(todo (cdr common-rcs))
(done empty-rules))
(if (null? todo)
(common-rules-add done rc)
(each-rc (car todo) (cdr todo) (common-rules-add done rc)))))))
;;;
;;; returns a list containing three elements or false
;;; the first element is the left part of the match
;;; the second element is the middle part of the match
;;; the third element is the right part of the match
;;;
;;; (is-matched-by? "%.o" "bar.o") ---> '("" "bar" ".o")
;;; (is-matched-by? "%.tex" "bar.o") ---> #f
;;;
(define (is-matched-by? target-descr target-name)
(let* ((submatches (map (lambda (match-no)
(match:substring
(regexp-search (rx (: (submatch (* any))
(submatch "%")
(submatch (* any))))
target-descr)
match-no))
(list 1 2 3)))
(left (list-ref submatches 0))
(middle (list-ref submatches 1))
(right (list-ref submatches 2))
(constructed-rx (if (string=? "%" middle)
(rx (: (submatch ,left)
(submatch (* any))
(submatch ,right)))
(rx (: (submatch ,left)
(submatch ,middle)
(submatch ,right)))))
(maybe-match (regexp-search constructed-rx target-name)))
(if maybe-match
(map (lambda (match-no)
(match:substring maybe-match match-no))
(list 1 2 3))
#f)))
;;;
;;; returns the string where the match is replaced with replacement
;;; or the identity of maybe-match
;;;
;;; (replace-by-match "no-percents.c" "foo") ---> "no-percents.c"
;;; (replace-by-match "%.c" "foo") ---> "foo.c"
;;;
(define (replace-by-match maybe-match replacement)
(regexp-substitute/global
#f
(rx (: (submatch (* any)) (submatch "%") (submatch (* any))))
maybe-match
'pre 1 replacement 3 'post))
(define (common-rules-show common-rules)
(display "\n=== \n=== COMMON RULES") (newline)
(for-each (lambda (common-rule)
(display "=== ") (newline)
(let* ((target (common-rule-target common-rule))
(prereqs (common-rule-prereqs common-rule))
(wants-build? (common-rule-wants-build? common-rule))
(build-func (common-rule-build-func common-rule)))
(display "=== target : ") (display target) (newline)
(display "=== prereqs : ") (display prereqs) (newline)
(display "=== wants-build? : ") (display wants-build?) (newline)
(display "=== build-func : ") (display build-func) (newline)))
common-rules)
(newline))

280
macros.scm
View File

@ -1,24 +1,60 @@
;;;
;;; MAKEFILE: ;;; MAKEFILE:
;;; ========= ;;; =========
;;;
;;; ;;;
;;; <makefile> ::= '(' + "makefile" + <makerule-clause>* + ')' ;;; <makefile> ::= '(' + "makefile" + <makerule-clause>* + ')'
;;; <makerule-clause> ::= <file-clause> ;;; <makerule-clause> ::= <file-clause>
;;; | <all-clause>
;;; | <md5-clause> ;;; | <md5-clause>
;;; | <always-clause> ;;; | <always-clause>
;;; | <once-clause> ;;; | <once-clause>
;;; | <common-file-clause>
;;; | <common-all-clause>
;;; | <common-md5-clause>
;;; | <common-always-clause>
;;; | <common-once-clause>
;;; ;;;
;;; ;;;
(define-syntax makefile (define-syntax makefile
(syntax-rules () (syntax-rules ()
((makefile) (list)) ((makefile ?rule0 ...)
((makefile ?rule0 ?rule1 ...) (?rule0 (makefile ?rule1 ...))))) (sort-rules () () ?rule0 ...))))
;;; ;;;
;;; <file-clause> ;;; Each rule will be transformed into something similar to this:
;;; ;;;
;;; to achieve consistency only rule will use the rule-tmpvars ;;; (cons ()
;;; macro directly and all other macros use this clause ;;; ("target" ("prereq0" ...) is-out-of-date? (lambda () ?action0 ...)))
;;;
;;; or this
;;;
;;; (cons ("target" ("prereq0" ...) is-out-of-date? (lambda () ?action0 ...)
;;; ()))
;;;
;;; The car of each result then goes into the file-rules-list while the
;;; cdr goes into the common-rules-list. At the end those elements in each
;;; of the file-rules-list and the common-rules-list being empty lists are
;;; removed. The result are the cons-ed remaining lists.
;;;
(define-syntax sort-rules
(syntax-rules ()
((sort-rules (?file0 ...) (?common0 ...))
(let ((file-rules (remove null? (list ?file0 ...)))
(common-rules (remove null? (list ?common0 ...))))
(cons file-rules common-rules)))
((sort-rules (?file1 ...) (?common1 ...) ?rule0 ?rule1 ...)
(let ((rule-result ?rule0))
(let ((common0 (cdr rule-result))
(file0 (car rule-result)))
(sort-rules (file0 ?file1 ...) (common0 ?common1 ...) ?rule1 ...))))))
;;;
;;; MAKERULE-CLAUSES:
;;; =================
;;;
;;;
;;; <file-clause>
;;; ;;;
(define-syntax makefile-rule (define-syntax makefile-rule
(syntax-rules () (syntax-rules ()
@ -41,22 +77,55 @@
(let ((target ?target) (let ((target ?target)
(prereqs (list tmp1 ...)) (prereqs (list tmp1 ...))
(thunk (lambda () ?action0 ...))) (thunk (lambda () ?action0 ...)))
(lambda (rule-candidates)
(cons (list target (cons (list target
prereqs prereqs
(make-is-out-of-date? target tmp1 ...) (make-is-out-of-date? target tmp1 ...)
(make-file-build-func target prereqs thunk)) (make-file-build-func target prereqs thunk))
rule-candidates)))) (list))))
((file-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?action0 ...) ((file-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
?action0 ...)
(let ((tmp2 ?prereq0)) (let ((tmp2 ?prereq0))
(file-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?action0 ...))))) (file-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
?action0 ...)))))
;;;
;;; <all-clause>
;;;
(define-syntax all
(syntax-rules ()
((makefile-rule ?target ?prereqs ?action0 ...)
(file-all ?target ?prereqs ?action0 ...))))
(define-syntax all-out-of-date?
(syntax-rules ()
((all-out-of-date? ?target ?prereqs ?action0 ...)
(file-all ?target ?prereqs ?action0 ...))))
(define-syntax file-all
(syntax-rules ()
((file-all ?target (?prereq0 ...) ?action0 ...)
(file-all-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
(define-syntax file-all-tmpvars
(syntax-rules ()
((file-all-tmpvars (tmp1 ...) ?target () ?action0 ...)
(let ((target ?target)
(prereqs (list tmp1 ...))
(thunk (lambda () ?action0 ...)))
(cons (list target
prereqs
(make-all-out-of-date? target tmp1 ...)
(make-all-build-func target prereqs thunk))
(list))))
((file-all-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
?action0 ...)
(let ((tmp2 ?prereq0))
(file-all-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
?action0 ...)))))
;;; ;;;
;;; <md5-clause> ;;; <md5-clause>
;;; ;;;
;;; to achieve consistency only file-md5 will use the file-md5-tmpvars
;;; macro directly and all other macros use this clause
;;;
(define-syntax md5 (define-syntax md5
(syntax-rules () (syntax-rules ()
((md5 ?target ?prereqs ?action0 ...) ((md5 ?target ?prereqs ?action0 ...)
@ -73,22 +142,20 @@
(let ((target ?target) (let ((target ?target)
(prereqs (list tmp1 ...)) (prereqs (list tmp1 ...))
(thunk (lambda () ?action0 ...))) (thunk (lambda () ?action0 ...)))
(lambda (rule-candidates)
(cons (list target (cons (list target
prereqs prereqs
(make-md5-sum-changed? target tmp1 ...) (make-md5-sum-changed? target tmp1 ...)
(make-md5-build-func target prereqs thunk)) (make-md5-build-func target prereqs thunk))
rule-candidates)))) (list))))
((file-md5-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?action0 ...) ((file-md5-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
?action0 ...)
(let ((tmp2 ?prereq0)) (let ((tmp2 ?prereq0))
(file-md5-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?action0 ...))))) (file-md5-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
?action0 ...)))))
;;; ;;;
;;; <always-clause> ;;; <always-clause>
;;; ;;;
;;; to achieve consistency only rule-always will use the rule-always-tmpvars
;;; macro directly and all other macros use this clause
;;;
(define-syntax phony (define-syntax phony
(syntax-rules () (syntax-rules ()
((phony ?target ?prereqs ?action0 ...) ((phony ?target ?prereqs ?action0 ...)
@ -115,22 +182,20 @@
(let ((target ?target) (let ((target ?target)
(prereqs (list tmp1 ...)) (prereqs (list tmp1 ...))
(thunk (lambda () ?action0 ...))) (thunk (lambda () ?action0 ...)))
(lambda (rule-candidates)
(cons (list target (cons (list target
prereqs prereqs
(make-is-out-of-date! target tmp1 ...) (make-is-out-of-date! target tmp1 ...)
(make-always-build-func target prereqs thunk)) (make-always-build-func target prereqs thunk))
rule-candidates)))) (list))))
((file-always-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?action0 ...) ((file-always-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
?action0 ...)
(let ((tmp2 ?prereq0)) (let ((tmp2 ?prereq0))
(file-always-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?action0 ...))))) (file-always-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
?action0 ...)))))
;;; ;;;
;;; <once-clause> ;;; <once-clause>
;;; ;;;
;;; to achieve consistency only rule-once will use the rule-once-tmpvars
;;; macro directly and all other macros use this clause
;;;
(define-syntax once (define-syntax once
(syntax-rules () (syntax-rules ()
((once ?target ?prereqs ?action0 ...) ((once ?target ?prereqs ?action0 ...)
@ -147,12 +212,165 @@
(let ((target ?target) (let ((target ?target)
(prereqs (list tmp1 ...)) (prereqs (list tmp1 ...))
(thunk (lambda () ?action0 ...))) (thunk (lambda () ?action0 ...)))
(lambda (rule-candidates)
(cons (list target (cons (list target
prereqs prereqs
(make-once target tmp1 ...) (make-once target tmp1 ...)
(make-once-build-func target prereqs thunk)) (make-once-build-func target prereqs thunk))
rule-candidates)))) (list))))
((file-once-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?action0 ...) ((file-once-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
?action0 ...)
(let ((tmp2 ?prereq0)) (let ((tmp2 ?prereq0))
(file-once-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?action0 ...))))) (file-once-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
?action0 ...)))))
;;; COMMON-MAKERULE-CLAUSES:
;;; ========================
;;;
;;;
;;;
;;; <common-file-clause>
;;;
(define-syntax common-file
(syntax-rules ()
((common-file ?target (?prereq0 ...) ?action0 ...)
(common-file-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
(define-syntax common-file-tmpvars
(syntax-rules ()
((common-file-tmpvars (tmp1 ...) ?target () ?action0 ...)
(let ((target ?target)
(prereqs (list tmp1 ...))
(thunk (lambda () ?action0 ...)))
(cons (list)
(list target
prereqs
(make-common-is-out-of-date? target tmp1 ...)
(make-common-file-build-func target prereqs thunk)))))
((common-file-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
?action0 ...)
(let ((tmp2 ?prereq0))
(common-file-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
?action0 ...)))))
;;;
;;; <common-all-clause>
;;;
;;; to achieve consistency only file will use the file-tmpvars
;;; macro directly and all other macros use this clause
;;;
(define-syntax common-all
(syntax-rules ()
((common-all ?target ?prereqs ?action0 ...)
(common-file-all ?target ?prereqs ?action0 ...))))
(define-syntax common-file-all
(syntax-rules ()
((common-file-all ?target (?prereq0 ...) ?action0 ...)
(common-file-all-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
(define-syntax common-file-all-tmpvars
(syntax-rules ()
((common-file-all-tmpvars (tmp1 ...) ?target () ?action0 ...)
(let ((target ?target)
(prereqs (list tmp1 ...))
(thunk (lambda () ?action0 ...)))
(cons (list)
(list target
prereqs
(make-common-all-out-of-date? target tmp1 ...)
(make-common-all-build-func target prereqs thunk)))))
((common-file-all-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
?action0 ...)
(let ((tmp2 ?prereq0))
(common-file-all-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
?action0 ...)))))
;;;
;;; <common-md5-clause>
;;;
(define-syntax common-md5
(syntax-rules ()
((common-md5 ?target ?prereqs ?action0 ...)
(common-file-md5 ?target ?prereqs ?action0 ...))))
(define-syntax common-file-md5
(syntax-rules ()
((common-file-md5 ?target (?prereq0 ...) ?action0 ...)
(common-file-md5-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
(define-syntax common-file-md5-tmpvars
(syntax-rules ()
((common-file-md5-tmpvars (tmp1 ...) ?target () ?action0 ...)
(let ((target ?target)
(prereqs (list tmp1 ...))
(thunk (lambda () ?action0 ...)))
(cons (list)
(list target
prereqs
(make-common-md5-sum-changed? target tmp1 ...)
(make-common-md5-build-func target prereqs thunk)))))
((common-file-md5-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
?action0 ...)
(let ((tmp2 ?prereq0))
(common-file-md5-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
?action0 ...)))))
;;;
;;; <common-always-clause>
;;;
(define-syntax common-always
(syntax-rules ()
((common-always ?target ?prereqs ?action0 ...)
(common-file-always ?target ?prereqs ?action0 ...))))
(define-syntax common-file-always
(syntax-rules ()
((common-file-always ?target ?prereqs ?action0 ...)
(common-file-always-tmpvars () ?target ?prereqs ?action0 ...))))
(define-syntax common-file-always-tmpvars
(syntax-rules ()
((common-file-always-tmpvars (tmp1 ...) ?target () ?action0 ...)
(let ((target ?target)
(prereqs (list tmp1 ...))
(thunk (lambda () ?action0 ...)))
(cons (list)
(list target
prereqs
(make-common-is-out-of-date! target tmp1 ...)
(make-common-always-build-func target prereqs thunk)))))
((common-file-always-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
?action0 ...)
(let ((tmp2 ?prereq0))
(common-file-always-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
?action0 ...)))))
;;;
;;; <common-once-clause>
;;;
(define-syntax common-once
(syntax-rules ()
((common-once ?target ?prereqs ?action0 ...)
(common-file-once ?target ?prereqs ?action0 ...))))
(define-syntax common-file-once
(syntax-rules ()
((common-file-once ?target (?prereq0 ...) ?action0 ...)
(common-file-once-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
(define-syntax common-file-once-tmpvars
(syntax-rules ()
((common-file-once-tmpvars (tmp1 ...) ?target () ?action0 ...)
(let ((target ?target)
(prereqs (list tmp1 ...))
(thunk (lambda () ?action0 ...)))
(cons (list)
(list target
prereqs
(make-common-once target tmp1 ...)
(make-common-once-build-func target prereqs thunk)))))
((common-file-once-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
?action0 ...)
(let ((tmp2 ?prereq0))
(common-file-once-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
?action0 ...)))))

4
make.scm
View File

@ -1,6 +1,8 @@
(define (make rcs targets . maybe-arg) (define (make rcs targets . maybe-arg)
(let-optionals maybe-arg ((init-state (list))) (let-optionals maybe-arg ((init-state (list)))
(let* ((rules (rcs->rules rcs)) (let* ((common-rule-candidates (cdr rcs))
(rule-candidates (car rcs))
(rules (rcs->rules rule-candidates common-rule-candidates))
(rule-set (rules->rule-set rules)) (rule-set (rules->rule-set rules))
(target-rules (map (lambda (t) (lookup-rule t rules)) (target-rules (map (lambda (t) (lookup-rule t rules))
targets))) targets)))

67
packages.scm
View File

@ -184,7 +184,14 @@
(always :syntax) (always :syntax)
(is-out-of-date! :syntax) (is-out-of-date! :syntax)
(once :syntax) (once :syntax)
(file-once :syntax))) (file-once :syntax)
(common-file :syntax)
(common-md5 :syntax)
(common-file-md5 :syntax)
(common-always :syntax)
(common-file-always :syntax)
(common-once :syntax)
(common-file-once :syntax)))
(define-structure macros macros-interface (define-structure macros macros-interface
(open scheme-with-scsh (open scheme-with-scsh
@ -210,6 +217,7 @@
srfi-1 srfi-1
templates templates
make-rule make-rule
common-rules
dfs) dfs)
(files to-rule-set)) (files to-rule-set))
@ -226,19 +234,10 @@
threads threads
srfi-1 srfi-1
srfi-9 srfi-9
misc
let-opt let-opt
(with-prefix rendezvous-channels cml-sync-ch/)) (with-prefix rendezvous-channels cml-sync-ch/))
(files dfs)) (files dfs))
(define-interface misc-interface
(export sort
insert))
(define-structure misc misc-interface
(open scheme-with-scsh)
(files misc))
(define-interface templates-interface (define-interface templates-interface
(export make-file-build-func (export make-file-build-func
make-md5-build-func make-md5-build-func
@ -247,10 +246,19 @@
make-is-out-of-date! make-is-out-of-date!
make-once make-once
make-is-out-of-date? make-is-out-of-date?
make-md5-sum-changed?)) make-md5-sum-changed?
make-common-file-build-func
make-common-md5-build-func
make-common-always-build-func
make-common-once-build-func
make-common-is-out-of-date!
make-common-once
make-common-is-out-of-date?
make-common-md5-sum-changed?))
(define-structure templates templates-interface (define-structure templates templates-interface
(open scheme-with-scsh (open scheme-with-scsh
common-rules
autovars autovars
srfi-1 srfi-1
big-util big-util
@ -258,17 +266,21 @@
(files templates)) (files templates))
(define-interface autovars-interface (define-interface autovars-interface
(export bind-fluids-gnu (export bind-fluids-common
bind-fluids-gnu
fluid-$@ fluid-$@
fluid-$< fluid-$<
fluid-$? fluid-$?
fluid-$^ fluid-$^
fluid-$+ fluid-$+
fluid-$* fluid-$*
fluid-$=*
fluid-$*=
fluid-$=*=
fluid-$@/ fluid-$@/
fluid-/$@ fluid-/$@
fluid-$*/ fluid-$=*=/
fluid-/$* fluid-/$=*=
fluid-$</ fluid-$</
fluid-/$< fluid-/$<
fluid-$^/ fluid-$^/
@ -283,10 +295,13 @@
$^ $^
$+ $+
$* $*
$=*
$*=
$=*=
$@/ $@/
/$@ /$@
$*/ $=*=/
/$* /$=*=
$</ $</
/$< /$<
$^/ $^/
@ -305,6 +320,24 @@
srfi-13) srfi-13)
(files autovars)) (files autovars))
(define-interface common-rules-interface
(export make-empty-common-rules
common-rules-add
common-rules-show
search-match-in-common-rules
common-rcs->common-rules
is-matched-by?
replace-by-match))
(define-structure common-rules common-rules-interface
(open scheme-with-scsh
autovars
srfi-1
srfi-9
big-util
srfi-13)
(files common-rules))
(define-structure make (export make) (define-structure make (export make)
(open scheme-with-scsh (open scheme-with-scsh
srfi-1 srfi-1
@ -314,4 +347,4 @@
make-rule) make-rule)
(files make)) (files make))
(define make-rule make-rule-cml) (define make-rule make-rule-no-cml)

35
templates.scm
View File

@ -190,3 +190,38 @@
#f)) #f))
(else (error "no match in same-checksum?")))))) (else (error "no match in same-checksum?"))))))
(else (error "no match in same-checksum?"))))))) (else (error "no match in same-checksum?")))))))
(define (make-common-is-out-of-date? target-descr . prereqs)
(lambda args (apply make-is-out-of-date? args)))
(define (make-common-file-build-func target-descr prereqs thunk)
(lambda (target-name cooked-prereqs)
(make-file-build-func target-name cooked-prereqs thunk)))
(define (make-common-all-out-of-date? target-descr . prereqs)
(lambda args (apply make-all-out-of-date? args)))
(define (make-common-all-build-func target-descr prereqs thunk)
(lambda (target-name cooked-prereqs)
(make-all-build-func target-name cooked-prereqs thunk)))
(define (make-common-md5-sum-changed? target-descr . prereqs)
(lambda args (apply make-md5-sum-changed? args)))
(define (make-common-md5-build-func target-descr prereqs thunk)
(lambda (target-name cooked-prereqs)
(make-md5-build-func target-name cooked-prereqs thunk)))
(define (make-common-is-out-of-date! target-descr . prereqs)
(lambda args (apply make-is-out-of-date! args)))
(define (make-common-always-build-func target-descr prereqs thunk)
(lambda (target-name cooked-prereqs)
(make-always-build-func target-name cooked-prereqs thunk)))
(define (make-common-once target-descr . prereqs)
(lambda args (apply make-common-once args)))
(define (make-common-once-build-func target-descr prereqs thunk)
(lambda (target-name cooked-prereqs)
(make-once-build-func target-name cooked-prereqs thunk)))

27
to-rule-set.scm
View File

@ -1,3 +1,10 @@
(define (rc->dfs-node rc)
(let ((target (list-ref rc 0))
(prereqs (list-ref rc 1))
(wants-build? (list-ref rc 2))
(build-func (list-ref rc 3)))
(make-dfs target prereqs (list wants-build? build-func))))
(define (rcs->dag rcs) (define (rcs->dag rcs)
(map (lambda (rc) (map (lambda (rc)
(let ((target (list-ref rc 0)) (let ((target (list-ref rc 0))
@ -22,14 +29,7 @@
(let ((wants-build? (car ignored)) (let ((wants-build? (car ignored))
(build-func (cadr ignored))) (build-func (cadr ignored)))
(list target prereqs wants-build? build-func)) (list target prereqs wants-build? build-func))
(let* ((tfname (expand-file-name target (cwd))) (error "node without wants-build? and build-func"))))
(wants-build? (lambda args
(cons (file-not-exists? tfname)
(last args))))
(build-func (lambda args
(error "file (assumed leaf) does not exist:"
tfname))))
(list target prereqs wants-build? build-func)))))
dag)) dag))
(define (lookup-rc rc rcs) (define (lookup-rc rc rcs)
@ -50,11 +50,16 @@
(cdr maybe-rule) (cdr maybe-rule)
(error "lookup-rule: fname not found in rules.")))) (error "lookup-rule: fname not found in rules."))))
(define (rcs->rules rule-candidates) (define (rcs->rules rule-candidates common-rcs)
(let* ((sorted-dag (dfs (rcs->dag rule-candidates))) (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))))
(sorted-dag (dfs (rcs->dag rule-candidates) string=? #t create-leaf))
(sorted-rcs (dag->rcs sorted-dag))) (sorted-rcs (dag->rcs sorted-dag)))
;;(common-rules-show common-rules) (newline)
;;(dfs-dag-show sorted-dag (car sorted-dag)) ;;(dfs-dag-show sorted-dag (car sorted-dag))
;; (rcs-show sorted-rcs)
(if (not (null? sorted-rcs)) (if (not (null? sorted-rcs))
(let for-all-rcs ((rc (car sorted-rcs)) (let for-all-rcs ((rc (car sorted-rcs))
(todo (cdr sorted-rcs)) (todo (cdr sorted-rcs))