new syntax for makefile.
This commit is contained in:
jottbee
parent
a5852a70ba
commit
57b9ebfe8b
88
SYNTAX
88
SYNTAX
|
|
@ -1,18 +1,18 @@
|
|||
MAKEFILE:
|
||||
=========
|
||||
|
||||
<makefile> ::= '(' + "makefile" + <makerule-clause>* + ')'
|
||||
<makefile> ::= '(' + "makefile" + { <makerule-clause> | <common-clause> }* ')'
|
||||
|
||||
<makerule-clause> ::= <file-clause>
|
||||
| <all-clause>
|
||||
| <md5-clause>
|
||||
| <md5-clause>
|
||||
| <always-clause>
|
||||
| <once-clause>
|
||||
| <common-file-clause>
|
||||
| <common-all-clause>
|
||||
| <common-md5-clause>
|
||||
| <common-always-clause>
|
||||
| <common-once-clause>
|
||||
| <once-clause>
|
||||
| <perms-clause>
|
||||
| <md5-perms-clause>
|
||||
| <paranoid-clause>
|
||||
|
||||
<common-clause> ::= '(' + "common" + <makerule-clause>* + ')'
|
||||
|
||||
<file-clause> ::= '(' + <fille-clause-identifier>
|
||||
+ <target-spec>
|
||||
|
|
@ -29,6 +29,21 @@ MAKEFILE:
|
|||
+ <prereq-spec>
|
||||
+ <action-spec> + ')'
|
||||
|
||||
<perms-clause> ::= '(' + <perms-clause-identifier>
|
||||
+ <target-spec>
|
||||
+ <prereq-spec>
|
||||
+ <action-spec> + ')'
|
||||
|
||||
<md5-perms-clause> ::= '(' + <md5-perms-clause-identifier>
|
||||
+ <target-spec>
|
||||
+ <prereq-spec>
|
||||
+ <action-spec> + ')'
|
||||
|
||||
<paranoid-clause> ::= '(' + <paranoid-clause-identifier>
|
||||
+ <target-spec>
|
||||
+ <prereq-spec>
|
||||
+ <action-spec> + ')'
|
||||
|
||||
<always-clause> ::= '(' + <always-clause-identifier>
|
||||
+ <target-spec>
|
||||
+ <prereq-spec>
|
||||
|
|
@ -44,63 +59,18 @@ MAKEFILE:
|
|||
| "is-out-of-date?"
|
||||
|
||||
<all-clause-identifier> ::= "all"
|
||||
| "file-all"
|
||||
| "all-out-of-date?"
|
||||
|
||||
<md5-clause-identifier> ::= "md5"
|
||||
| "file-md5"
|
||||
| "fp-changed?"
|
||||
|
||||
<perms-clause-identifier> ::= "perms"
|
||||
|
||||
<md5-perms-clause-identifier> ::= "md5-perms"
|
||||
|
||||
<paranoid-clause-identifier> ::= "paranoid"
|
||||
|
||||
<always-clause-identifier> ::= "always"
|
||||
| "file-always"
|
||||
| "phony"
|
||||
| "is-out-of-date!"
|
||||
|
||||
<once-clause-identifier> ::= "once"
|
||||
| "file-once"
|
||||
|
||||
<common-file-clause> ::= '(' + <common-file-clause-identifier>
|
||||
+ <common-target-spec>
|
||||
+ <common-prereq-spec>
|
||||
+ <action>+ + ')'
|
||||
|
||||
<common-all-clause> ::= '(' + <common-all-clause-identifier>
|
||||
+ <common-target-spec>
|
||||
+ <common-prereq-spec>
|
||||
+ <action>+ + ')'
|
||||
|
||||
<common-md5-clause> ::= '(' + <common-md5-clause-identifier>
|
||||
+ <common-target-spec>
|
||||
+ <common-prereq-spec>
|
||||
+ <action-spec> + ')'
|
||||
|
||||
<common-always-clause> ::= '(' + <common-always-clause-identifier>
|
||||
+ <common-target-spec>
|
||||
+ <common-prereq-spec>
|
||||
+ <action-spec> + ')'
|
||||
|
||||
<common-once-clause> ::= '(' + <common-once-clause-identifier>
|
||||
+ <common-target-spec>
|
||||
+ <common-prereq-spec>
|
||||
+ <action-spec> + ')'
|
||||
|
||||
<common-file-clause-identifier> ::= "common-file"
|
||||
| "common-makefile-rule"
|
||||
| "common-is-out-of-date?"
|
||||
|
||||
<common-all-clause-identifier> ::= "common-all"
|
||||
| "common-file-all"
|
||||
| "common-all-out-of-date?"
|
||||
|
||||
<common-md5-clause-identifier> ::= "common-md5"
|
||||
| "common-file-md5"
|
||||
| "common-fp-changed?"
|
||||
|
||||
<common-always-clause-identifier> ::= "common-always"
|
||||
| "common-file-always"
|
||||
|
||||
<common-once-clause-identifier> ::= "common-once"
|
||||
| "common-file-once"
|
||||
|
||||
<common-target-spec> ::= <target-descr> | <target> | <target-list>
|
||||
<target-descr> ::= <target-pattern> | <target-rx>
|
||||
|
|
|
|||
|
|
@ -20,6 +20,9 @@
|
|||
(define fluid-$?/ (make-preserved-thread-fluid (list)))
|
||||
(define fluid-/$? (make-preserved-thread-fluid (list)))
|
||||
|
||||
(define (bind-all-fluids target prereqs prereqs-results thunk)
|
||||
(bind-fluids-gnu target prereqs prereqs-results thunk))
|
||||
|
||||
(define (bind-fluids-common target-name prefix match suffix thunk)
|
||||
(let (($* match)
|
||||
($*= suffix)
|
||||
|
|
|
|||
191
common-rules.scm
191
common-rules.scm
|
|
@ -1,157 +1,50 @@
|
|||
(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-record-type :common-rules
|
||||
(make-common-rules ls)
|
||||
is-common-rules?
|
||||
(ls common-rules-ls))
|
||||
|
||||
(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)))
|
||||
(make-common-rules (list match-all-func)))
|
||||
|
||||
(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 (error-if-nonexistant target)
|
||||
(error "file (assumed leaf) doesn't exist:" target))
|
||||
|
||||
(define (match-all-func default-target)
|
||||
(list default-target
|
||||
(list)
|
||||
(lambda args
|
||||
(let ((target (car args))
|
||||
(init-state (last args)))
|
||||
(cons (file-not-exists? default-target) init-state)))
|
||||
(lambda args
|
||||
(let ((target (car args))
|
||||
(cooked-state (last args)))
|
||||
(error-if-nonexistant target)))))
|
||||
|
||||
(define (add-common-rules common-rules func)
|
||||
(make-common-rules (cons func (common-rules-ls 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)
|
||||
(if (string? prereq)
|
||||
(replace-by-match prereq match)
|
||||
prereq))
|
||||
(common-rule-prereqs current)))
|
||||
(make-wants-build? (common-rule-wants-build? current))
|
||||
(wants-build?
|
||||
(lambda args
|
||||
(bind-fluids-common target-name prefix match suffix
|
||||
(lambda ()
|
||||
(apply
|
||||
(apply make-wants-build?
|
||||
(append (list target-name)
|
||||
cooked-prereqs))
|
||||
args)))))
|
||||
(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))))))))
|
||||
(let ((common-rs (common-rules-ls common-rules)))
|
||||
(if (null? common-rs)
|
||||
#f
|
||||
(let next-common-rule ((current (car common-rs))
|
||||
(todo (cdr common-rs)))
|
||||
(let ((maybe-target (current target)))
|
||||
(if maybe-target
|
||||
maybe-target
|
||||
(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
|
||||
(define (common-rcs->common-rules common-rcs)
|
||||
(let ((empty-rules (make-empty-common-rules)))
|
||||
(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 (if (string? target-descr)
|
||||
(get-submatches-percent target-descr)
|
||||
#f)))
|
||||
(if submatches
|
||||
(let* ((left (list-ref submatches 0))
|
||||
(middle (list-ref submatches 1))
|
||||
(right (list-ref submatches 2))
|
||||
(constructed-rx (if (and (string? middle) (string=? "%" middle))
|
||||
(rx (: (submatch (: bos ,left))
|
||||
(submatch (* any))
|
||||
(submatch (: ,right eos))))
|
||||
(rx (: (submatch (: bos ,left))
|
||||
(submatch ,middle)
|
||||
(submatch (: ,right eos))))))
|
||||
(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))
|
||||
(let ((maybe-match (regexp-search target-descr target-name)))
|
||||
(if maybe-match
|
||||
(map (lambda (match-no) (match:substring maybe-match match-no))
|
||||
(list 1 2 3))
|
||||
#f)))))
|
||||
|
||||
(define (get-submatches-percent target-descr)
|
||||
(map (lambda (match-no)
|
||||
(match:substring (regexp-search (rx (: (submatch (: bos (* any)))
|
||||
(submatch "%")
|
||||
(submatch (: (* any) eos))))
|
||||
target-descr)
|
||||
match-no))
|
||||
(list 1 2 3)))
|
||||
|
||||
;;;
|
||||
;;; 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))
|
||||
(let for-each-rc ((rc (car common-rcs))
|
||||
(todo (cdr common-rcs))
|
||||
(done empty-rules))
|
||||
(let ((current (add-common-rules done rc)))
|
||||
(if (null? todo)
|
||||
current
|
||||
(for-each-rc (car todo) (cdr todo) current)))))))
|
||||
|
|
|
|||
|
|
@ -4,33 +4,48 @@
|
|||
"libwildio.so.1" "libmymath.so.1"
|
||||
"libwildio.so" "libmymath.so"
|
||||
"show-sqrt"
|
||||
"manual.dvi" "manual.pdf" "manual.log" "manual.aux"))
|
||||
"manual.dvi" "manual.pdf" "manual.ps" "manual.log" "manual.aux"
|
||||
"a-manual.dvi" "a-manual.pdf" "a-manual.ps" "a-manual.log" "a-manual.aux"
|
||||
"b-manual.dvi" "b-manual.pdf" "b-manual.ps" "b-manual.log" "b-manual.aux"
|
||||
"c-manual.dvi" "c-manual.pdf" "c-manual.ps" "c-manual.log" "c-manual.aux"
|
||||
"d-manual.dvi" "d-manual.pdf" "d-manual.ps" "d-manual.log" "d-manual.aux"
|
||||
"e-manual.dvi" "e-manual.pdf" "e-manual.ps" "e-manual.log" "e-manual.aux"
|
||||
"f-manual.dvi" "f-manual.pdf" "f-manual.ps" "f-manual.log" "f-manual.aux"
|
||||
"g-manual.dvi" "g-manual.pdf" "g-manual.ps" "g-manual.log" "g-manual.aux"
|
||||
"h-manual.dvi" "h-manual.pdf" "h-manual.ps" "h-manual.log" "h-manual.aux"
|
||||
"i-manual.dvi" "i-manual.pdf" "i-manual.ps" "i-manual.log" "i-manual.aux"
|
||||
"j-manual.dvi" "j-manual.pdf" "j-manual.ps" "j-manual.log" "j-manual.aux"
|
||||
"another-manual.dvi" "another-manual.pdf" "another-manual.ps"
|
||||
"another-manual.log" "another-manual.aux"))
|
||||
|
||||
;(string-append ($*) ".c") (string-append ($*) ".h")
|
||||
(define file-set
|
||||
(makefile
|
||||
(common-file "%.o"
|
||||
("%.c" "%.h")
|
||||
(run (gcc -fPIC -c ,($<))))
|
||||
(common-file "lib%.so.1.0"
|
||||
("%.o")
|
||||
(run
|
||||
(gcc -shared ,(string-append "-Wl,-soname," ($=*) ".so.1")
|
||||
-o ,($@) ,($<))))
|
||||
(common-file "lib%.so.1"
|
||||
("lib%.so.1.0")
|
||||
(create-symlink ($<) ($@)))
|
||||
(common-file "lib%.so"
|
||||
("lib%.so.1")
|
||||
(create-symlink ($<) ($@)))
|
||||
(common-file "%.dvi"
|
||||
("%.tex")
|
||||
(run (latex ,($<))))
|
||||
(common-file "%.pdf"
|
||||
("%.dvi")
|
||||
(run (dvipdfm -o ,($@) ,($<))))
|
||||
(common-file "%.ps"
|
||||
("%.dvi")
|
||||
(run (dvips -o ,($@) ,($<))))
|
||||
(common-rx
|
||||
(file (rx (: (submatch "") (submatch (+ any)) (submatch ".o")))
|
||||
("%.c" "%.h")
|
||||
(run (gcc -fPIC -c ,(string-append ($*) ".c")))))
|
||||
(common-%
|
||||
(file "lib%.so.1.0"
|
||||
("%.o")
|
||||
(run
|
||||
(gcc -shared ,(string-append "-Wl,-soname," ($=*) ".so.1")
|
||||
-o ,($@) ,($<))))
|
||||
(file "lib%.so.1"
|
||||
("lib%.so.1.0")
|
||||
(create-symlink ($<) ($@)))
|
||||
(file "lib%.so"
|
||||
("lib%.so.1")
|
||||
(create-symlink ($<) ($@)))
|
||||
(file "%.dvi"
|
||||
("%.tex")
|
||||
(run (latex ,($<))))
|
||||
(file "%.pdf"
|
||||
("%.dvi")
|
||||
(run (dvipdfm -o ,($@) ,($<))))
|
||||
(file "%.ps"
|
||||
("%.dvi")
|
||||
(run (dvips -o ,($@) ,($<)))))
|
||||
;;
|
||||
;; build the program
|
||||
;;
|
||||
|
|
@ -42,7 +57,18 @@
|
|||
;; fake install
|
||||
;;
|
||||
(always "install"
|
||||
("show-sqrt" "manual.ps" "manual.dvi" "manual.pdf")
|
||||
("show-sqrt" "manual.ps" "manual.pdf"
|
||||
"another-manual.pdf" "another-manual.ps"
|
||||
"a-manual.dvi" "a-manual.pdf" "a-manual.ps"
|
||||
"b-manual.dvi" "b-manual.pdf" "b-manual.ps"
|
||||
"c-manual.dvi" "c-manual.pdf" "c-manual.ps"
|
||||
"d-manual.dvi" "d-manual.pdf" "d-manual.ps"
|
||||
"e-manual.dvi" "e-manual.pdf" "e-manual.ps"
|
||||
"f-manual.dvi" "f-manual.pdf" "f-manual.ps"
|
||||
"g-manual.dvi" "g-manual.pdf" "g-manual.ps"
|
||||
"h-manual.dvi" "h-manual.pdf" "h-manual.ps"
|
||||
"i-manual.dvi" "i-manual.pdf" "i-manual.ps"
|
||||
"j-manual.dvi" "j-manual.pdf" "j-manual.ps")
|
||||
(for-each (lambda (f) (display ">>> ") (display f) (newline)) ($+))
|
||||
(display "install done.\n"))
|
||||
;;
|
||||
|
|
|
|||
518
macros.scm
518
macros.scm
|
|
@ -1,376 +1,166 @@
|
|||
;;;
|
||||
;;; MAKEFILE:
|
||||
;;; =========
|
||||
;;;
|
||||
;;;
|
||||
;;; <makefile> ::= '(' + "makefile" + <makerule-clause>* + ')'
|
||||
;;; <makerule-clause> ::= <file-clause>
|
||||
;;; | <all-clause>
|
||||
;;; | <md5-clause>
|
||||
;;; | <always-clause>
|
||||
;;; | <once-clause>
|
||||
;;; | <common-file-clause>
|
||||
;;; | <common-all-clause>
|
||||
;;; | <common-md5-clause>
|
||||
;;; | <common-always-clause>
|
||||
;;; | <common-once-clause>
|
||||
;;;
|
||||
;;;
|
||||
(define-syntax makefile
|
||||
(syntax-rules ()
|
||||
((makefile ?rule0 ...)
|
||||
(sort-rules () () ?rule0 ...))))
|
||||
(syntax-rules (pred)
|
||||
((makefile ?clauses ...)
|
||||
(let ((id=? string=?))
|
||||
(clauses->lists id=? () () ?clauses ...)))
|
||||
((makefile (pred id=?) ?clauses ...)
|
||||
(clauses->lists id=? () () ?clauses ...))))
|
||||
|
||||
;;;
|
||||
;;; Each rule will be transformed into something similar to this:
|
||||
;;;
|
||||
;;; (cons ()
|
||||
;;; ("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 ...))))))
|
||||
(define-syntax clauses->lists
|
||||
(syntax-rules (common-% common-rx)
|
||||
((clauses->lists pred (?rc0 ...) (?func1 ...) (common-% ?%0 ...) ?clause1 ...)
|
||||
(clauses->lists pred
|
||||
(?rc0 ...)
|
||||
(?func1 ... (common-%-clause->func pred ?%0) ...)
|
||||
?clause1 ...))
|
||||
((clauses->lists pred (?rc0 ...) (?func1 ...) (common-rx ?rx0 ...) ?clause1 ...)
|
||||
(clauses->lists pred
|
||||
(?rc0 ...)
|
||||
(?func1 ... (common-rx-clause->func pred ?rx0) ...)
|
||||
?clause1 ...))
|
||||
((clauses->lists pred (?rc1 ...) (?func0 ...) ?clause0 ?clause1 ...)
|
||||
(clauses->lists pred
|
||||
(?rc1 ... (clause->rc pred ?clause0))
|
||||
(?func0 ...)
|
||||
?clause1 ...))
|
||||
((clauses->lists pred (?rc0 ...) (?func0 ...))
|
||||
(rcs+commons->rules pred
|
||||
(list ?rc0 ...)
|
||||
(list ?func0 ...)))))
|
||||
|
||||
;;;
|
||||
;;; MAKERULE-CLAUSES:
|
||||
;;; =================
|
||||
;;;
|
||||
;;;
|
||||
;;; <file-clause>
|
||||
;;;
|
||||
(define-syntax makefile-rule
|
||||
(define-syntax common-rx-clause->func
|
||||
(syntax-rules ()
|
||||
((makefile-rule ?target ?prereqs ?action0 ...)
|
||||
(file ?target ?prereqs ?action0 ...))))
|
||||
((common-rx-clause->func pred
|
||||
(?out-of-date?-func ?target-rx
|
||||
(?prereq-pattern0 ...)
|
||||
?action0 ...))
|
||||
(lambda (maybe-target)
|
||||
(let ((target-rx ?target-rx))
|
||||
(common-clause->func maybe-target
|
||||
target-rx
|
||||
pred
|
||||
(?out-of-date?-func ?target-rx
|
||||
(?prereq-pattern0 ...)
|
||||
?action0 ...)))))))
|
||||
|
||||
(define-syntax is-out-of-date?
|
||||
(define-syntax common-%-clause->func
|
||||
(syntax-rules ()
|
||||
((is-out-of-date? ?target ?prereqs ?action0 ...)
|
||||
(file ?target ?prereqs ?action0 ...))))
|
||||
((common-%-clause->func pred
|
||||
(?out-of-date?-func ?target-pattern
|
||||
(?prereq-pattern0 ...)
|
||||
?action0 ...))
|
||||
(lambda (maybe-target)
|
||||
(let* ((pattern ?target-pattern)
|
||||
(left (common-%-pattern->match pattern 1))
|
||||
(middle (common-%-pattern->match pattern 2))
|
||||
(right (common-%-pattern->match pattern 3))
|
||||
(target-rx (if (string=? "%" middle)
|
||||
(rx (: (submatch (: bos ,left))
|
||||
(submatch (* any))
|
||||
(submatch (: ,right eos))))
|
||||
(rx (: (submatch (: bos ,left))
|
||||
(submatch ,middle)
|
||||
(submatch (: ,right eos)))))))
|
||||
(common-clause->func maybe-target
|
||||
target-rx
|
||||
pred
|
||||
(?out-of-date?-func ?target-pattern
|
||||
(?prereq-pattern0 ...)
|
||||
?action0 ...)))))))
|
||||
|
||||
(define-syntax file
|
||||
(define-syntax common-%-pattern->match
|
||||
(syntax-rules ()
|
||||
((file ?target (?prereq0 ...) ?action0 ...)
|
||||
(file-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
|
||||
((common-%-pattern->match ?target-pattern ?no)
|
||||
(match:substring (regexp-search (rx (: (submatch (: bos (* any)))
|
||||
(submatch "%")
|
||||
(submatch (: (* any) eos))))
|
||||
?target-pattern)
|
||||
?no))))
|
||||
|
||||
(define-syntax file-tmpvars
|
||||
(define-syntax common-s/%/match
|
||||
(syntax-rules ()
|
||||
((file-tmpvars (tmp1 ...) ?target () ?action0 ...)
|
||||
((common-s/%/match ?pattern ?match)
|
||||
(regexp-substitute/global
|
||||
#f (rx (: (submatch (: bos (* any)))
|
||||
(submatch "%")
|
||||
(submatch (: (* any) eos)))) ?pattern 'pre 1 ?match 3 'post))))
|
||||
|
||||
(define-syntax common-clause->func
|
||||
(syntax-rules ()
|
||||
((common-clause->func maybe-target
|
||||
target-rx
|
||||
pred
|
||||
(?out-of-date?-func ?target-pattern
|
||||
(?prereq-pattern0 ...)
|
||||
?action0 ...))
|
||||
(let* ((match-data (regexp-search target-rx maybe-target))
|
||||
(maybe-target-matches (if match-data
|
||||
(map (lambda (no)
|
||||
(match:substring match-data no))
|
||||
(list 1 2 3))
|
||||
#f)))
|
||||
(if maybe-target-matches
|
||||
(let* ((left (list-ref maybe-target-matches 0))
|
||||
(target-match (list-ref maybe-target-matches 1))
|
||||
(right (list-ref maybe-target-matches 2))
|
||||
(target-name (string-append left target-match right))
|
||||
(prereqs (list ?prereq-pattern0 ...))
|
||||
(cooked-prereqs (map (lambda (prereq)
|
||||
(if (string? prereq)
|
||||
(common-s/%/match prereq target-match)
|
||||
prereq))
|
||||
prereqs)))
|
||||
(list target-name
|
||||
cooked-prereqs
|
||||
;;out-to-date?-func
|
||||
(lambda args
|
||||
(let ((init-state (last args)))
|
||||
(cons (bind-fluids-common
|
||||
target-name left target-match right
|
||||
(lambda ()
|
||||
(?out-of-date?-func target-name
|
||||
cooked-prereqs)))
|
||||
init-state)))
|
||||
;; build-func
|
||||
(lambda args
|
||||
(let ((cooked-state (last args))
|
||||
(prereqs-results (cdr (reverse (cdr args)))))
|
||||
(cons (bind-fluids-common
|
||||
target-name left target-match right
|
||||
(lambda ()
|
||||
(bind-all-fluids target-name
|
||||
cooked-prereqs
|
||||
prereqs-results
|
||||
(lambda () ?action0 ...))))
|
||||
cooked-state)))))
|
||||
#f)))))
|
||||
|
||||
(define-syntax clause->rc
|
||||
(syntax-rules ()
|
||||
((clause->rc pred (?func ?target (?prereq0 ...) ?action0 ...))
|
||||
(clause->rc-tmp () pred (?func ?target (?prereq0 ...) ?action0 ...)))))
|
||||
|
||||
(define-syntax clause->rc-tmp
|
||||
(syntax-rules ()
|
||||
((clause->rc-tmp (tmp1 ...) pred (?func ?target () ?action0 ...))
|
||||
(let ((target ?target)
|
||||
(prereqs (list tmp1 ...))
|
||||
(thunk (lambda () ?action0 ...)))
|
||||
(cons (list target
|
||||
prereqs
|
||||
(make-is-out-of-date? target tmp1 ...)
|
||||
(make-file-build-func target prereqs thunk))
|
||||
(list))))
|
||||
((file-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
|
||||
?action0 ...)
|
||||
(prereqs (list tmp1 ...)))
|
||||
(list target
|
||||
prereqs
|
||||
(lambda args
|
||||
(let ((init-state (last args)))
|
||||
(cons (?func target (list tmp1 ...))
|
||||
init-state)))
|
||||
(lambda args
|
||||
(let ((cooked-state (last args))
|
||||
(results (cdr (reverse (cdr args)))))
|
||||
(cons (bind-all-fluids target prereqs results
|
||||
(lambda () ?action0 ...))
|
||||
cooked-state))))))
|
||||
((clause->rc-tmp (tmp1 ...)
|
||||
pred
|
||||
(?func ?target (?prereq0 ?prereq1 ...) ?action0 ...))
|
||||
(let ((tmp2 ?prereq0))
|
||||
(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>
|
||||
;;;
|
||||
(define-syntax md5
|
||||
(syntax-rules ()
|
||||
((md5 ?target ?prereqs ?action0 ...)
|
||||
(file-md5 ?target ?prereqs ?action0 ...))))
|
||||
|
||||
(define-syntax file-md5
|
||||
(syntax-rules ()
|
||||
((file-md5 ?target (?prereq0 ...) ?action0 ...)
|
||||
(file-md5-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
|
||||
|
||||
(define-syntax file-md5-tmpvars
|
||||
(syntax-rules ()
|
||||
((file-md5-tmpvars (tmp1 ...) ?target () ?action0 ...)
|
||||
(let ((target ?target)
|
||||
(prereqs (list tmp1 ...))
|
||||
(thunk (lambda () ?action0 ...)))
|
||||
(cons (list target
|
||||
prereqs
|
||||
(make-md5-sum-changed? target tmp1 ...)
|
||||
(make-md5-build-func target prereqs thunk))
|
||||
(list))))
|
||||
((file-md5-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
|
||||
?action0 ...)
|
||||
(let ((tmp2 ?prereq0))
|
||||
(file-md5-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
|
||||
?action0 ...)))))
|
||||
|
||||
;;;
|
||||
;;; <always-clause>
|
||||
;;;
|
||||
(define-syntax phony
|
||||
(syntax-rules ()
|
||||
((phony ?target ?prereqs ?action0 ...)
|
||||
(file-always ?target ?prereqs ?action0 ...))))
|
||||
|
||||
(define-syntax always
|
||||
(syntax-rules ()
|
||||
((always ?target ?prereqs ?action0 ...)
|
||||
(file-always ?target ?prereqs ?action0 ...))))
|
||||
|
||||
(define-syntax is-out-of-date!
|
||||
(syntax-rules ()
|
||||
((is-out-of-date! ?target ?prereqs ?action0 ...)
|
||||
(file-always ?target ?prereqs ?action0 ...))))
|
||||
|
||||
(define-syntax file-always
|
||||
(syntax-rules ()
|
||||
((file-always ?target ?prereqs ?action0 ...)
|
||||
(file-always-tmpvars () ?target ?prereqs ?action0 ...))))
|
||||
|
||||
(define-syntax file-always-tmpvars
|
||||
(syntax-rules ()
|
||||
((file-always-tmpvars (tmp1 ...) ?target () ?action0 ...)
|
||||
(let ((target ?target)
|
||||
(prereqs (list tmp1 ...))
|
||||
(thunk (lambda () ?action0 ...)))
|
||||
(cons (list target
|
||||
prereqs
|
||||
(make-is-out-of-date! target tmp1 ...)
|
||||
(make-always-build-func target prereqs thunk))
|
||||
(list))))
|
||||
((file-always-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
|
||||
?action0 ...)
|
||||
(let ((tmp2 ?prereq0))
|
||||
(file-always-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...)
|
||||
?action0 ...)))))
|
||||
|
||||
;;;
|
||||
;;; <once-clause>
|
||||
;;;
|
||||
(define-syntax once
|
||||
(syntax-rules ()
|
||||
((once ?target ?prereqs ?action0 ...)
|
||||
(file-once ?target ?prereqs ?action0 ...))))
|
||||
|
||||
(define-syntax file-once
|
||||
(syntax-rules ()
|
||||
((file-once ?target (?prereq0 ...) ?action0 ...)
|
||||
(file-once-tmpvars () ?target (?prereq0 ...) ?action0 ...))))
|
||||
|
||||
(define-syntax file-once-tmpvars
|
||||
(syntax-rules ()
|
||||
((file-once-tmpvars (tmp1 ...) ?target () ?action0 ...)
|
||||
(let ((target ?target)
|
||||
(prereqs (list tmp1 ...))
|
||||
(thunk (lambda () ?action0 ...)))
|
||||
(cons (list target
|
||||
prereqs
|
||||
(make-once target tmp1 ...)
|
||||
(make-once-build-func target prereqs thunk))
|
||||
(list))))
|
||||
((file-once-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...)
|
||||
?action0 ...)
|
||||
(let ((tmp2 ?prereq0))
|
||||
(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 ...)))))
|
||||
(clause->rc-tmp (tmp1 ... tmp2)
|
||||
pred
|
||||
(?func ?target (?prereq1 ...) ?action0 ...))))))
|
||||
|
|
|
|||
13
make.scm
13
make.scm
|
|
@ -1,10 +1,9 @@
|
|||
(define (make rcs targets . maybe-arg)
|
||||
(let-optionals maybe-arg ((init-state (list)))
|
||||
(let* ((common-rule-candidates (cdr rcs))
|
||||
(rule-candidates (car rcs))
|
||||
(rules (rcs->rules rule-candidates common-rule-candidates))
|
||||
(rule-set (rules->rule-set rules))
|
||||
(target-rules (map (lambda (t) (lookup-rule t rules))
|
||||
(define (make rules targets . maybe-args)
|
||||
(let-optionals maybe-args ((pred string=?)
|
||||
(init-state (list)))
|
||||
(let* ((rule-set (rules->rule-set rules))
|
||||
(target-rules (map (lambda (target)
|
||||
(lookup-rule pred target rules))
|
||||
targets)))
|
||||
(map (lambda (t)
|
||||
(rule-make t init-state rule-set))
|
||||
|
|
|
|||
64
packages.scm
64
packages.scm
|
|
@ -128,8 +128,8 @@
|
|||
(open scheme-with-scsh
|
||||
finite-types
|
||||
srfi-9
|
||||
big-util ; for breakpoints
|
||||
let-opt ; for logging
|
||||
; big-util ; for breakpoints
|
||||
; let-opt ; for logging
|
||||
threads
|
||||
threads-internal
|
||||
(with-prefix rendezvous cml-rv/)
|
||||
|
|
@ -139,6 +139,7 @@
|
|||
|
||||
(define-interface make-rule-interface
|
||||
(export make-rule
|
||||
; set!-target/rule-alist
|
||||
is-rule?
|
||||
make-empty-rule-set
|
||||
rule-set-add
|
||||
|
|
@ -155,7 +156,7 @@
|
|||
with-lock
|
||||
threads
|
||||
threads-internal
|
||||
big-util ; for breakpoints
|
||||
; big-util ; for breakpoints
|
||||
srfi-1
|
||||
srfi-9
|
||||
finite-types
|
||||
|
|
@ -174,24 +175,7 @@
|
|||
(files make-rule-no-cml))
|
||||
|
||||
(define-interface macros-interface
|
||||
(export (makefile :syntax)
|
||||
(file :syntax)
|
||||
(makefile-rule :syntax)
|
||||
(is-out-of-date? :syntax)
|
||||
(md5 :syntax)
|
||||
(file-md5 :syntax)
|
||||
(phony :syntax)
|
||||
(always :syntax)
|
||||
(is-out-of-date! :syntax)
|
||||
(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)))
|
||||
(export (makefile :syntax)))
|
||||
|
||||
(define-structure macros macros-interface
|
||||
(open scheme-with-scsh
|
||||
|
|
@ -209,7 +193,7 @@
|
|||
lookup-rule
|
||||
rcs->dag
|
||||
dag->rcs
|
||||
rcs->rules
|
||||
rcs+commons->rules
|
||||
rules->rule-set))
|
||||
|
||||
(define-structure to-rule-set to-rule-set-interface
|
||||
|
|
@ -239,35 +223,28 @@
|
|||
(files dfs))
|
||||
|
||||
(define-interface templates-interface
|
||||
(export make-file-build-func
|
||||
make-md5-build-func
|
||||
make-always-build-func
|
||||
make-once-build-func
|
||||
make-is-out-of-date!
|
||||
make-once
|
||||
make-is-out-of-date?
|
||||
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?))
|
||||
(export all
|
||||
file
|
||||
md5
|
||||
always
|
||||
perms
|
||||
md5-perms
|
||||
paranoid
|
||||
once))
|
||||
|
||||
(define-structure templates templates-interface
|
||||
(open scheme-with-scsh
|
||||
common-rules
|
||||
autovars
|
||||
srfi-1
|
||||
big-util
|
||||
; big-util
|
||||
srfi-13)
|
||||
(files templates))
|
||||
|
||||
(define-interface autovars-interface
|
||||
(export bind-fluids-common
|
||||
bind-fluids-gnu
|
||||
bind-all-fluids
|
||||
fluid-$@
|
||||
fluid-$<
|
||||
fluid-$?
|
||||
|
|
@ -322,19 +299,16 @@
|
|||
|
||||
(define-interface common-rules-interface
|
||||
(export make-empty-common-rules
|
||||
common-rules-add
|
||||
common-rules-show
|
||||
add-common-rules
|
||||
search-match-in-common-rules
|
||||
common-rcs->common-rules
|
||||
is-matched-by?
|
||||
replace-by-match))
|
||||
common-rcs->common-rules))
|
||||
|
||||
(define-structure common-rules common-rules-interface
|
||||
(open scheme-with-scsh
|
||||
autovars
|
||||
srfi-1
|
||||
srfi-9
|
||||
big-util
|
||||
; big-util
|
||||
srfi-13)
|
||||
(files common-rules))
|
||||
|
||||
|
|
|
|||
196
templates.scm
196
templates.scm
|
|
@ -1,122 +1,45 @@
|
|||
(define digest-extensions (list ".md5" ".fp" ".digest"))
|
||||
|
||||
(define (make-file-build-func target prereqs thunk)
|
||||
(lambda args
|
||||
; (breakpoint "make-file-build-func")
|
||||
(let ((cooked-state (last args))
|
||||
(prereqs-results (cdr (reverse (cdr args)))))
|
||||
(cons (begin
|
||||
(display ";;; file : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(bind-fluids-gnu target prereqs prereqs-results thunk))
|
||||
cooked-state))))
|
||||
(define (same-mtime? target prereqs)
|
||||
(if (file-not-exists? target)
|
||||
#t
|
||||
(if (null? prereqs)
|
||||
#f
|
||||
(let ((target-mtime (file-last-mod target)))
|
||||
(let for-each-prereq ((prereq (car prereqs))
|
||||
(todo (cdr prereqs)))
|
||||
(cond
|
||||
((file-not-exists? prereq)
|
||||
(error "nonexistent prerequisite" prereq))
|
||||
((> (file-last-mod prereq) target-mtime) #t)
|
||||
((null? todo) #f)
|
||||
(else (for-each-prereq (car todo) (cdr todo)))))))))
|
||||
|
||||
(define (make-all-build-func target prereqs thunk)
|
||||
(lambda args
|
||||
; (breakpoint "make-file-build-func")
|
||||
(let ((cooked-state (last args))
|
||||
(prereqs-results (cdr (reverse (cdr args)))))
|
||||
(cons (begin
|
||||
(display ";;; all : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(bind-fluids-gnu target prereqs prereqs-results thunk))
|
||||
cooked-state))))
|
||||
(define (all-same-mtime? target prereqs)
|
||||
(if (file-not-exists? target)
|
||||
#t
|
||||
(if (null? prereqs)
|
||||
#f
|
||||
(let ((target-mtime (file-last-mod target)))
|
||||
(let for-each-prereq ((prereq (car prereqs))
|
||||
(todo (cdr prereqs)))
|
||||
(cond
|
||||
((file-not-exists? prereq)
|
||||
(error "nonexistent prerequisite" prereq))
|
||||
((and (null? todo)
|
||||
(> (file-last-mod prereq) target-mtime)) #t)
|
||||
(else (and (> (file-last-mod prereq) target-mtime)
|
||||
(for-each-prereq (car todo) (cdr todo))))))))))
|
||||
|
||||
(define (make-md5-build-func target prereqs thunk)
|
||||
(lambda args
|
||||
; (breakpoint "make-md5-build-func")
|
||||
(let ((cooked-state (last args))
|
||||
(prereqs-results (cdr (reverse (cdr args)))))
|
||||
(cons (begin
|
||||
(display ";;; md5 : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(bind-fluids-gnu target prereqs prereqs-results thunk))
|
||||
cooked-state))))
|
||||
|
||||
(define (make-always-build-func target prereqs thunk)
|
||||
(lambda args
|
||||
; (breakpoint "make-always-build-func")
|
||||
(let ((cooked-state (last args))
|
||||
(prereqs-results (cdr (reverse (cdr args)))))
|
||||
(cons (begin
|
||||
(display ";;; always : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(bind-fluids-gnu target prereqs prereqs-results thunk))
|
||||
cooked-state))))
|
||||
|
||||
(define (make-once-build-func target prereqs thunk)
|
||||
(lambda args
|
||||
; (breakpoint "make-once-build-func")
|
||||
(let ((cooked-state (last args))
|
||||
(prereqs-results (cdr (reverse (cdr args)))))
|
||||
(cons (begin
|
||||
(display ";;; once : ")
|
||||
(display target)
|
||||
(newline)
|
||||
(bind-fluids-gnu target prereqs prereqs-results thunk))
|
||||
cooked-state))))
|
||||
|
||||
(define (make-is-out-of-date! target . prereqs)
|
||||
(lambda args
|
||||
; (breakpoint "make-is-out-of-date!")
|
||||
(let ((init-state (last args)))
|
||||
(cons #t init-state))))
|
||||
|
||||
(define (make-once target . prereqs)
|
||||
(lambda args
|
||||
; (breakpoint "make-once")
|
||||
(let ((init-state (last args)))
|
||||
(cons (file-not-exists? target) init-state))))
|
||||
|
||||
(define (make-is-out-of-date? target . prereqs)
|
||||
(lambda args
|
||||
; (breakpoint "make-is-out-of-date?")
|
||||
(let ((init-state (last args)))
|
||||
(cons (if (file-not-exists? target)
|
||||
#t
|
||||
(if (null? prereqs)
|
||||
#f
|
||||
(let ((target-mtime (file-last-mod target)))
|
||||
(let for-each-prereq ((prereq (car prereqs))
|
||||
(todo (cdr prereqs)))
|
||||
(cond
|
||||
((file-not-exists? prereq)
|
||||
(error "nonexistent prerequisite" prereq))
|
||||
((> (file-last-mod prereq) target-mtime) #t)
|
||||
((null? todo) #f)
|
||||
(else (for-each-prereq (car todo) (cdr todo))))))))
|
||||
init-state))))
|
||||
|
||||
(define (make-all-out-of-date? target . prereqs)
|
||||
(lambda args
|
||||
; (breakpoint "make-is-out-of-date?")
|
||||
(let ((init-state (last args)))
|
||||
(cons (if (file-not-exists? target)
|
||||
#t
|
||||
(if (null? prereqs)
|
||||
#f
|
||||
(let ((target-mtime (file-last-mod target)))
|
||||
(let for-each-prereq ((prereq (car prereqs))
|
||||
(todo (cdr prereqs)))
|
||||
(cond
|
||||
((file-not-exists? prereq)
|
||||
(error "nonexistent prerequisite" prereq))
|
||||
((and (null? todo)
|
||||
(> (file-last-mod prereq) target-mtime)) #t)
|
||||
(else (and (> (file-last-mod prereq) target-mtime)
|
||||
(for-each-prereq (car todo) (cdr todo)))))))))
|
||||
init-state))))
|
||||
|
||||
(define (make-md5-sum-changed? target . prereqs)
|
||||
(lambda args
|
||||
; (breakpoint "make-md5-sum-changed?")
|
||||
(let ((init-state (last args)))
|
||||
(cons (not (same-checksum? target digest-extensions prereqs))
|
||||
init-state))))
|
||||
(define (same-perms? target prereqs)
|
||||
(if (file-not-exists? target)
|
||||
#t
|
||||
(if (null? prereqs)
|
||||
(error "no prerequisite in perms clause")
|
||||
(cond
|
||||
((file-not-exists? (car prereqs))
|
||||
(error "nonexistent prerequisite" (car prereqs)))
|
||||
(else (= (file-mode target) (file-mode (car prereqs))))))))
|
||||
|
||||
(define (checksum-from-file basename extension)
|
||||
(let* ((bname (string-append basename extension))
|
||||
|
|
@ -193,37 +116,28 @@
|
|||
(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 (always target prereqs) #t)
|
||||
|
||||
(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 (once target prereqs)
|
||||
(file-not-exists? target))
|
||||
|
||||
(define (make-common-all-out-of-date? target-descr . prereqs)
|
||||
(lambda args (apply make-all-out-of-date? args)))
|
||||
(define (file target prereqs)
|
||||
(same-mtime? target prereqs))
|
||||
|
||||
(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 (all target prereqs)
|
||||
(all-same-mtime? target prereqs))
|
||||
|
||||
(define (make-common-md5-sum-changed? target-descr . prereqs)
|
||||
(lambda args (apply make-md5-sum-changed? args)))
|
||||
(define (md5 target prereqs)
|
||||
(not (same-checksum? target digest-extensions prereqs)))
|
||||
|
||||
(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 (perms target prereqs)
|
||||
(not (same-perms? target prereqs)))
|
||||
|
||||
(define (make-common-is-out-of-date! target-descr . prereqs)
|
||||
(lambda args (apply make-is-out-of-date! args)))
|
||||
(define (md5-perms target prereqs)
|
||||
(and (not (same-checksum? target digest-extensions prereqs))
|
||||
(not (same-perms? target prereqs))
|
||||
(not (same-mtime? target prereqs))))
|
||||
|
||||
(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 (paranoid target prereqs)
|
||||
(not (same-checksum? target digest-extensions prereqs)))
|
||||
|
||||
(define (make-common-once target-descr . prereqs)
|
||||
(lambda args (apply make-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)))
|
||||
|
|
|
|||
|
|
@ -14,11 +14,6 @@
|
|||
(make-dfs target prereqs (list wants-build? build-func))))
|
||||
rcs))
|
||||
|
||||
;;;
|
||||
;;; if dfs inserted leafs they have the ignored-data set to #f
|
||||
;;; the build-func will then be set to produce an error
|
||||
;;; in case of the file doesn't exist
|
||||
;;;
|
||||
(define (dag->rcs dag)
|
||||
(map (lambda (node)
|
||||
(let* ((ls (dfs->list node))
|
||||
|
|
@ -44,22 +39,22 @@
|
|||
rcs)))
|
||||
(if maybe-fname maybe-fname (error "lookup-fname: fname not found."))))
|
||||
|
||||
(define (lookup-rule fname rules)
|
||||
(let ((maybe-rule (assoc fname rules)))
|
||||
(define (lookup-rule pred fname rules)
|
||||
(let ((maybe-rule (find (lambda (current)
|
||||
(pred fname (car current)))
|
||||
rules)))
|
||||
(if maybe-rule
|
||||
(cdr maybe-rule)
|
||||
(error "lookup-rule: fname not found in rules."))))
|
||||
|
||||
(define (rcs->rules rule-candidates common-rcs)
|
||||
(define (rcs+commons->rules pred rule-candidates common-rcs)
|
||||
(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-dag (dfs (rcs->dag rule-candidates) pred #t create-leaf))
|
||||
(sorted-rcs (dag->rcs sorted-dag)))
|
||||
;;(common-rules-show common-rules) (newline)
|
||||
;;(dfs-dag-show sorted-dag (car sorted-dag))
|
||||
(if (not (null? sorted-rcs))
|
||||
(let for-all-rcs ((rc (car sorted-rcs))
|
||||
(todo (cdr sorted-rcs))
|
||||
|
|
@ -69,15 +64,18 @@
|
|||
(wants-build? (list-ref rc 2))
|
||||
(build-func (list-ref rc 3))
|
||||
(done (cons (cons target
|
||||
(make-rule (map (lambda (p)
|
||||
(lookup-rule p last-done))
|
||||
(make-rule (map (lambda (prereq)
|
||||
(lookup-rule pred
|
||||
prereq
|
||||
last-done))
|
||||
prereqs)
|
||||
wants-build?
|
||||
build-func))
|
||||
last-done)))
|
||||
(if (not (null? todo))
|
||||
(for-all-rcs (car todo) (cdr todo) done)
|
||||
done))))))
|
||||
(if (null? todo)
|
||||
done
|
||||
(for-all-rcs (car todo) (cdr todo) done))))
|
||||
sorted-rcs)))
|
||||
|
||||
(define (rules->rule-set rule-alist)
|
||||
(if (not (null? rule-alist))
|
||||
|
|
@ -91,37 +89,3 @@
|
|||
(cdr rules-to-do)
|
||||
next-rule-set)
|
||||
next-rule-set))))))
|
||||
|
||||
(define (rcs-show rcs)
|
||||
(newline) (newline) (newline) (newline)
|
||||
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
|
||||
(display ";;; rcs-show ;;;\n")
|
||||
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
|
||||
(let ((rc-show (lambda (rc)
|
||||
(let ((target (list-ref rc 0))
|
||||
(prereqs (list-ref rc 1))
|
||||
(wants-build? (list-ref rc 2))
|
||||
(build-func (list-ref rc 3)))
|
||||
(newline)
|
||||
(display "; target: ")
|
||||
(display target)
|
||||
(newline)
|
||||
(display "; prereqs: ")
|
||||
(display prereqs)
|
||||
(newline)
|
||||
(display "; wants-build?: ")
|
||||
(display wants-build?)
|
||||
(newline)
|
||||
(display "; build-func: ")
|
||||
(display build-func)
|
||||
(newline)))))
|
||||
(if (not (null? rcs))
|
||||
(let visit-each-rc ((current-rc (car rcs))
|
||||
(todo-rcs (cdr rcs)))
|
||||
(rc-show current-rc)
|
||||
(if (not (null? todo-rcs))
|
||||
(visit-each-rc (car todo-rcs) (cdr todo-rcs))
|
||||
(begin
|
||||
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
|
||||
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
|
||||
(newline) (newline) (newline) (newline)))))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue