168 lines
5.4 KiB
Scheme
168 lines
5.4 KiB
Scheme
(define-syntax makefile
|
|
(syntax-rules (pred)
|
|
((makefile ?clauses ...)
|
|
(let ((id=? string=?))
|
|
(clauses->lists id=? () () ?clauses ...)))
|
|
((makefile (pred id=?) ?clauses ...)
|
|
(clauses->lists id=? () () ?clauses ...))))
|
|
|
|
(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 ...)))))
|
|
|
|
(define-syntax common-rx-clause->func
|
|
(syntax-rules ()
|
|
((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 common-%-clause->func
|
|
(syntax-rules ()
|
|
((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 common-%-pattern->match
|
|
(syntax-rules ()
|
|
((common-%-pattern->match ?target-pattern ?no)
|
|
(match:substring (regexp-search (rx (: (submatch (: bos (* any)))
|
|
(submatch "%")
|
|
(submatch (: (* any) eos))))
|
|
?target-pattern)
|
|
?no))))
|
|
|
|
(define-syntax common-s/%/match
|
|
(syntax-rules ()
|
|
((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)))
|
|
(make-rule-cand 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 ...)))
|
|
(make-rule-cand 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))
|
|
(clause->rc-tmp (tmp1 ... tmp2)
|
|
pred
|
|
(?func ?target (?prereq1 ...) ?action0 ...))))))
|