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

added record type rule-cand

This commit is contained in:
jottbee 2005-03-08 13:14:36 +00:00
parent 57b9ebfe8b
commit 0205ebfd6a
7 changed files with 128 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
common-rules.scm
View File

@ -9,17 +9,17 @@
(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 (match-all-func will-be-target)
(make-rule-cand will-be-target
(list)
(lambda args
(let ((target (car args))
(init-state (last args)))
(cons (file-not-exists? will-be-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))))

62
dfs.scm
View File

@ -181,35 +181,33 @@
(cons (really-make-dfs name adjs (color black) time ignored)
(delete current-node current-dag)))))
(define (dfs-dag-show dag node)
(newline) (newline) (newline) (newline)
(display "************************************************************\n")
(display (dfs-name node)) (newline)
(display "************************************************************\n")
(let ((dfs-node-show (lambda (node)
(newline)
(display "~dfs-name: ")
(display (dfs-name node))
(newline)
(display "~dfs-adjacencies: ")
(display (dfs-adjacencies node))
(newline)
(display "~dfs-color: ")
(display (dfs-color node))
(newline)
(display "~dfs-ftime: ")
(display (dfs-ftime node))
(newline)
(display "~dfs-ignored: ")
(display (dfs-ignored node))
(newline))))
(if (not (null? dag))
(let visit-each-node ((current-node (car dag))
(nodes-to-do (cdr dag)))
(dfs-node-show current-node)
(if (not (null? nodes-to-do))
(visit-each-node (car nodes-to-do) (cdr nodes-to-do))
(begin
(display "************************************************************\n")
(display "************************************************************\n")
(newline) (newline) (newline) (newline)))))))
(define (dfs-dag-show dag . maybe-arg)
(let-optionals maybe-arg ((node (make-dfs "show dag" '() #f)))
(newline) (newline) (newline) (newline)
(display "************************************************************\n")
(display (dfs-name node)) (newline)
(display "************************************************************\n")
(let ((dfs-node-show (lambda (node)
(newline)
(display "~dfs-name: ")
(display (dfs-name node))
(newline)
(display "~dfs-adjacencies: ")
(display (dfs-adjacencies node))
(newline)
(display "~dfs-color: ")
(display (dfs-color node))
(newline)
(display "~dfs-ftime: ")
(display (dfs-ftime node))
(newline)
(display "~dfs-ignored: ")
(display (dfs-ignored node))
(newline))))
(if (not (null? dag))
(let visit-each-node ((current-node (car dag))
(nodes-to-do (cdr dag)))
(dfs-node-show current-node)
(if (not (null? nodes-to-do))
(visit-each-node (car nodes-to-do) (cdr nodes-to-do))
(newline)))))))

77
macros.scm
View File

@ -24,9 +24,9 @@
(?func0 ...)
?clause1 ...))
((clauses->lists pred (?rc0 ...) (?func0 ...))
(rcs+commons->rules pred
(list ?rc0 ...)
(list ?func0 ...)))))
(rcs+commons->rules pred
(list ?rc0 ...)
(list ?func0 ...)))))
(define-syntax common-rx-clause->func
(syntax-rules ()
@ -110,29 +110,30 @@
(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)))))
(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
@ -145,18 +146,18 @@
((clause->rc-tmp (tmp1 ...) pred (?func ?target () ?action0 ...))
(let ((target ?target)
(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))))))
(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 ...))

24
packages.scm
View File

@ -181,6 +181,7 @@
(open scheme-with-scsh
srfi-1
to-rule-set
rule-cand
dfs
autovars
templates
@ -199,9 +200,11 @@
(define-structure to-rule-set to-rule-set-interface
(open scheme-with-scsh
srfi-1
srfi-9
templates
make-rule
common-rules
rule-cand
dfs)
(files to-rule-set))
@ -298,20 +301,33 @@
(files autovars))
(define-interface common-rules-interface
(export make-empty-common-rules
(export common-rcs->common-rules
make-empty-common-rules
add-common-rules
search-match-in-common-rules
common-rcs->common-rules))
search-match-in-common-rules))
(define-structure common-rules common-rules-interface
(open scheme-with-scsh
autovars
srfi-1
srfi-9
; big-util
rule-cand
srfi-13)
(files common-rules))
(define-interface rule-cand-interface
(export make-rule-cand
is-rule-cand?
rule-cand-target
rule-cand-prereqs
rule-cand-up-to-date?-func
rule-cand-build-func))
(define-structure rule-cand rule-cand-interface
(open scheme-with-scsh
srfi-9)
(files rule-cand))
(define-structure make (export make)
(open scheme-with-scsh
srfi-1

7
rule-cand.scm Normal file
View File

@ -0,0 +1,7 @@
(define-record-type :rule-cand
(make-rule-cand target prereqs up-to-date?-func build-func)
is-rule-cand?
(target rule-cand-target)
(prereqs rule-cand-prereqs)
(up-to-date?-func rule-cand-up-to-date?-func)
(build-func rule-cand-build-func))

1
templates.scm
View File

@ -140,4 +140,3 @@
(define (paranoid target prereqs)
(not (same-checksum? target digest-extensions prereqs)))

40
to-rule-set.scm
View File

@ -1,16 +1,16 @@
(define (rc->dfs-node rc)
(let ((target (list-ref rc 0))
(prereqs (list-ref rc 1))
(wants-build? (list-ref rc 2))
(build-func (list-ref rc 3)))
(let ((target (rule-cand-target rc))
(prereqs (rule-cand-prereqs rc))
(wants-build? (rule-cand-up-to-date?-func rc))
(build-func (rule-cand-build-func rc)))
(make-dfs target prereqs (list wants-build? build-func))))
(define (rcs->dag rcs)
(map (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)))
(let ((target (rule-cand-target rc))
(prereqs (rule-cand-prereqs rc))
(wants-build? (rule-cand-up-to-date?-func rc))
(build-func (rule-cand-build-func rc)))
(make-dfs target prereqs (list wants-build? build-func))))
rcs))
@ -23,19 +23,19 @@
(if ignored
(let ((wants-build? (car ignored))
(build-func (cadr ignored)))
(list target prereqs wants-build? build-func))
(make-rule-cand target prereqs wants-build? build-func))
(error "node without wants-build? and build-func"))))
dag))
(define (lookup-rc rc rcs)
(define (lookup-rc pred rc rcs)
(let ((maybe-rc (find (lambda (current)
(eq? (car rc) (car current)))
(pred (car rc) (car current)))
rcs)))
(if maybe-rc maybe-rc (error "lookup-rc: rc not found."))))
(define (lookup-fname fname rcs)
(define (lookup-fname pred fname rcs)
(let ((maybe-fname (find (lambda (current)
(eq? fname (car current)))
(pred fname (car current)))
rcs)))
(if maybe-fname maybe-fname (error "lookup-fname: fname not found."))))
@ -53,16 +53,18 @@
(rc->dfs-node
(search-match-in-common-rules common-rules
maybe-target))))
(sorted-dag (dfs (rcs->dag rule-candidates) pred #t create-leaf))
(unsorted-dag (rcs->dag rule-candidates))
(sorted-dag (dfs unsorted-dag pred #t create-leaf))
(sorted-rcs (dag->rcs sorted-dag)))
;; (dfs-dag-show sorted-dag)
(if (not (null? sorted-rcs))
(let for-all-rcs ((rc (car sorted-rcs))
(todo (cdr sorted-rcs))
(last-done '()))
(let* ((target (list-ref rc 0))
(prereqs (list-ref rc 1))
(wants-build? (list-ref rc 2))
(build-func (list-ref rc 3))
(let* ((target (rule-cand-target rc))
(prereqs (rule-cand-prereqs rc))
(wants-build? (rule-cand-up-to-date?-func rc))
(build-func (rule-cand-build-func rc))
(done (cons (cons target
(make-rule (map (lambda (prereq)
(lookup-rule pred
@ -85,7 +87,7 @@
(rule-set (make-empty-rule-set)))
(let ((next-rule-set (rule-set-add current-rule rule-set)))
(if (not (null? rules-to-do))
(for-each-rule (car rules-to-do)
(for-each-rule (car rules-to-do)
(cdr rules-to-do)
next-rule-set)
next-rule-set))))))