128 lines
4.2 KiB
Scheme
128 lines
4.2 KiB
Scheme
(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)))
|
|
(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)))
|
|
(make-dfs target prereqs (list wants-build? build-func))))
|
|
rcs))
|
|
|
|
;;;
|
|
;;; if dfs inserted leafs they have the ignored-data set to #f
|
|
;;; the build-func will then be set to produce an error
|
|
;;; in case of the file doesn't exist
|
|
;;;
|
|
(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)))
|
|
(list target prereqs wants-build? build-func))
|
|
(error "node without wants-build? and build-func"))))
|
|
dag))
|
|
|
|
(define (lookup-rc rc rcs)
|
|
(let ((maybe-rc (find (lambda (current)
|
|
(eq? (car rc) (car current)))
|
|
rcs)))
|
|
(if maybe-rc maybe-rc (error "lookup-rc: rc not found."))))
|
|
|
|
(define (lookup-fname fname rcs)
|
|
(let ((maybe-fname (find (lambda (current)
|
|
(eq? fname (car current)))
|
|
rcs)))
|
|
(if maybe-fname maybe-fname (error "lookup-fname: fname not found."))))
|
|
|
|
(define (lookup-rule fname rules)
|
|
(let ((maybe-rule (assoc fname rules)))
|
|
(if maybe-rule
|
|
(cdr maybe-rule)
|
|
(error "lookup-rule: fname not found in rules."))))
|
|
|
|
(define (rcs->rules 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))))
|
|
(sorted-dag (dfs (rcs->dag rule-candidates) string=? #t create-leaf))
|
|
(sorted-rcs (dag->rcs sorted-dag)))
|
|
;;(common-rules-show common-rules) (newline)
|
|
;;(dfs-dag-show sorted-dag (car 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))
|
|
(done (cons (cons target
|
|
(make-rule (map (lambda (p)
|
|
(lookup-rule p last-done))
|
|
prereqs)
|
|
wants-build?
|
|
build-func))
|
|
last-done)))
|
|
(if (not (null? todo))
|
|
(for-all-rcs (car todo) (cdr todo) done)
|
|
done))))))
|
|
|
|
(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))))))
|
|
|
|
(define (rcs-show rcs)
|
|
(newline) (newline) (newline) (newline)
|
|
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
|
|
(display ";;; rcs-show ;;;\n")
|
|
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
|
|
(let ((rc-show (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)))
|
|
(newline)
|
|
(display "; target: ")
|
|
(display target)
|
|
(newline)
|
|
(display "; prereqs: ")
|
|
(display prereqs)
|
|
(newline)
|
|
(display "; wants-build?: ")
|
|
(display wants-build?)
|
|
(newline)
|
|
(display "; build-func: ")
|
|
(display build-func)
|
|
(newline)))))
|
|
(if (not (null? rcs))
|
|
(let visit-each-rc ((current-rc (car rcs))
|
|
(todo-rcs (cdr rcs)))
|
|
(rc-show current-rc)
|
|
(if (not (null? todo-rcs))
|
|
(visit-each-rc (car todo-rcs) (cdr todo-rcs))
|
|
(begin
|
|
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
|
|
(display ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n")
|
|
(newline) (newline) (newline) (newline)))))))
|