diff --git a/macros.scm b/macros.scm index d577b02..a91936c 100644 --- a/macros.scm +++ b/macros.scm @@ -35,13 +35,11 @@ (?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 ...))))))) + (let ((target-rx ?target-rx) + (thunk (lambda () ?action0 ...)) + (prereqs (list ?prereq-pattern0 ...))) + (common->func maybe-target target-rx pred + ?out-of-date?-func ?target-rx prereqs thunk)))))) (define-syntax common-%-clause->func (syntax-rules () @@ -50,91 +48,11 @@ (?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))))) + (let ((target-rx (%-pattern->rx ?target-pattern)) + (thunk (lambda () ?action0 ...)) + (prereqs (list ?prereq-pattern0 ...))) + (common->func maybe-target target-rx pred + ?out-of-date?-func ?target-pattern prereqs thunk)))))) (define-syntax clause->rc (syntax-rules () diff --git a/make.scm b/make.scm index 1132bd3..250bdd0 100644 --- a/make.scm +++ b/make.scm @@ -8,3 +8,166 @@ (map (lambda (t) (rule-make t init-state rule-set)) target-rules)))) + +(define (make-rc target prereqs out-of-date?-func thunk) + (make-rule-cand target + prereqs + (lambda args + (let ((init-state (last args))) + (cons (out-of-date?-func target prereqs) + init-state))) + (lambda args + (let ((cooked-state (last args)) + (results (cdr (reverse (cdr args))))) + (cons (bind-all-fluids target prereqs results thunk) + cooked-state))))) + +(define (file->rc target prereqs thunk) + (make-rc target prereqs file thunk)) + +(define (once->rc target prereqs thunk) + (make-rc target prereqs once thunk)) + +(define (all->rc target prereqs thunk) + (make-rc target prereqs all thunk)) + +(define (always->rc target prereqs thunk) + (make-rc target prereqs always thunk)) + +(define (perms->rc target prereqs thunk) + (make-rc target prereqs perms thunk)) + +(define (md5->rc target prereqs thunk) + (make-rc target prereqs md5 thunk)) + +(define (md5-perms->rc target prereqs thunk) + (make-rc target prereqs md5-perms thunk)) + +(define (paranoid->rc target prereqs thunk) + (make-rc target prereqs paranoid thunk)) + +(define (subst-% pattern match) + (regexp-substitute/global #f (rx (: (submatch (: bos (* any))) + (submatch "%") + (submatch (: (* any) eos)))) + pattern 'pre 1 match 3 'post)) + +(define (%-pattern->match pattern no) + (match:substring (regexp-search (rx (: (submatch (: bos (* any))) + (submatch "%") + (submatch (: (* any) eos)))) + pattern) + no)) + +(define (%-pattern->rx pattern) + (let* ((left (%-pattern->match pattern 1)) + (middle (%-pattern->match pattern 2)) + (right (%-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))))))) + target-rx)) + +(define (file-rx->rc target prereqs thunk) + (rx->func string=? target prereqs file thunk)) + +(define (once-rx->rc target prereqs thunk) + (rx->func string=? target prereqs once thunk)) + +(define (all-rx->rc target prereqs thunk) + (rx->func string=? target prereqs all thunk)) + +(define (always-rx->rc target prereqs thunk) + (rx->func string=? target prereqs always thunk)) + +(define (perms-rx->rc target prereqs thunk) + (rx->func string=? target prereqs perms thunk)) + +(define (md5-rx->rc target prereqs thunk) + (rx->func string=? target prereqs md5 thunk)) + +(define (md5-perms-rx->rc target prereqs thunk) + (rx->func string=? target prereqs md5-perms thunk)) + +(define (paranoid-rx->rc target prereqs thunk) + (rx->func string=? target prereqs paranoid thunk)) + +(define (rx->func pred target-rx prereqs out-of-date?-func thunk) + (lambda (maybe-target) + (common->func maybe-target target-rx pred + out-of-date?-func target-rx prereqs thunk))) + +(define (file-%->rc target prereqs thunk) + (%->func string=? target prereqs file thunk)) + +(define (once-%->rc target prereqs thunk) + (%->func string=? target prereqs once thunk)) + +(define (all-%->rc target prereqs thunk) + (%->func string=? target prereqs all thunk)) + +(define (always-%->rc target prereqs thunk) + (%->func string=? target prereqs always thunk)) + +(define (perms-%->rc target prereqs thunk) + (%->func string=? target prereqs perms thunk)) + +(define (md5-%->rc target prereqs thunk) + (%->func string=? target prereqs md5 thunk)) + +(define (md5-perms-%->rc target prereqs thunk) + (%->func string=? target prereqs md5-perms thunk)) + +(define (paranoid-%->rc target prereqs thunk) + (%->func string=? target prereqs paranoid thunk)) + +(define (%->func pred target-pattern prereqs out-of-date?-func thunk) + (lambda (maybe-target) + (let ((target-rx (%-pattern->rx target-pattern))) + (common->func maybe-target target-rx pred + out-of-date?-func target-pattern prereqs thunk)))) + +(define (common->func maybe-target target-rx pred + out-of-date?-func target-pattern prereqs thunk) + (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)) + (cooked-prereqs (map (lambda (prereq) + (if (string? prereq) + (subst-% prereq target-match) + prereq)) + prereqs))) + (make-rule-cand target-name + cooked-prereqs + (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))) + (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 + thunk))) + cooked-state))))) + #f))) diff --git a/packages.scm b/packages.scm index ba07763..d76181e 100644 --- a/packages.scm +++ b/packages.scm @@ -182,10 +182,8 @@ srfi-1 to-rule-set rule-cand - dfs autovars - templates - make-rule) + make) (files macros)) (define-interface to-rule-set-interface @@ -328,12 +326,48 @@ srfi-9) (files rule-cand)) -(define-structure make (export make) +(define-interface make-interface + (export make + make-rc + file->rc + once->rc + all->rc + always->rc + perms->rc + md5->rc + md5-perms->rc + paranoid->rc + %-pattern->match + %-pattern->rx + file-rx->rc + once-rx->rc + all-rx->rc + always-rx->rc + perms-rx->rc + md5-rx->rc + md5-perms-rx->rc + paranoid-rx->rc + file-%->rc + once-%->rc + all-%->rc + always-%->rc + perms-%->rc + md5-%->rc + md5-perms-%->rc + paranoid-%->rc + %->func + rx->func + common->func)) + +(define-structure make make-interface (open scheme-with-scsh srfi-1 - macros +; macros let-opt to-rule-set + templates + autovars + rule-cand make-rule) (files make))