scsh-make/to-rule-set.scm

94 lines
2.9 KiB
Scheme

(define (rc->dfs-node rc)
(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 (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))
(define (dag->rcs dag)
(map (lambda (node)
(let* ((ls (dfs->list node))
(target (list-ref ls 0))
(prereqs (list-ref ls 1))
(ignored (list-ref ls 2)))
(if ignored
(let ((wants-build? (car ignored))
(build-func (cadr ignored)))
(make-rule-cand target prereqs wants-build? build-func))
(error "node without wants-build? and build-func"))))
dag))
(define (lookup-rc pred rc rcs)
(let ((maybe-rc (find (lambda (current)
(pred (car rc) (car current)))
rcs)))
(if maybe-rc maybe-rc (error "lookup-rc: rc not found."))))
(define (lookup-fname pred fname rcs)
(let ((maybe-fname (find (lambda (current)
(pred fname (car current)))
rcs)))
(if maybe-fname maybe-fname #f)))
(define (lookup-rule pred fname rules)
(let ((maybe-rule (find (lambda (current)
(pred fname (car current)))
rules)))
(if maybe-rule
(cdr maybe-rule)
(error "lookup-rule: fname not found in rules."))))
(define (rcs+commons->rules pred rule-candidates common-rcs)
(let* ((common-rules (common-rcs->common-rules common-rcs))
(create-leaf (lambda (maybe-target)
(rc->dfs-node
(search-match-in-common-rules common-rules
maybe-target))))
(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 (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
prereq
last-done))
prereqs)
wants-build?
build-func))
last-done)))
(if (null? todo)
done
(for-all-rcs (car todo) (cdr todo) done))))
sorted-rcs)))
(define (rules->rule-set rule-alist)
(if (not (null? rule-alist))
(let ((rules (map cdr rule-alist)))
(let for-each-rule ((current-rule (car rules))
(rules-to-do (cdr rules))
(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)
(cdr rules-to-do)
next-rule-set)
next-rule-set))))))