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

embedded some commands for use with make into scsh

This commit is contained in:
jottbee 2005-03-09 14:49:13 +00:00
parent 0205ebfd6a
commit 554749cd20
3 changed files with 212 additions and 97 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

102
macros.scm
View File

@ -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 ()

163
make.scm
View File

@ -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)))

44
packages.scm
View File

@ -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))