140 lines
4.8 KiB
Scheme
140 lines
4.8 KiB
Scheme
|
(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))
|