scsh-make/rule-trans-set.scm

125 lines
4.9 KiB
Scheme
Raw Normal View History

2005-01-19 09:50:45 -05:00
;;; TODO:
;;;
;;; change to topological sort
2005-01-18 10:45:27 -05:00
;;;
;;; RULE-TRANS-SET
;;;
;;; (make-empty-rule-trans-set) ---> rule-trans-set
;;;
;;; (make-rule-trans-set rule-candidates known-rules rule-set)
;;;
;;; (rule-trans-set-rule-candidates rts) ---> (rule-candidate0 ...)
;;; (rule-trans-set-known-rules rts) ---> (known-rule0 ...)
;;; (rule-trans-set-rule-set rts) ---> rule-set
;;;
;;; (rule-trans-set-add! rule-trans-set target prereqs wants-build? build-func)
;;; ---> rule-trans-set
;;;
(define-record-type :rule-trans-set
(make-rule-trans-set rule-candidates known-rules rule-set)
is-rule-trans-set?
(rule-candidates rule-trans-set-rule-candidates)
(known-rules rule-trans-set-known-rules)
(rule-set rule-trans-set-rule-set))
(define (make-empty-rule-trans-set)
(let ((rule-candidates '())
(known-rules (alist-cons '() '() '()))
(rule-set (make-empty-rule-set)))
(make-rule-trans-set rule-candidates known-rules rule-set)))
2005-01-19 09:50:45 -05:00
;;; o every incoming rule is considered as a rule-candidate
;;; o add the new rule-candidate to rule-candidates
;;; o run known-rules-update afterwards
(define rule-trans-set-add
2005-01-18 14:28:50 -05:00
(lambda (rule-trans-set target prereqs wants-build? build-func)
(rule-candidate-add rule-trans-set target prereqs wants-build? build-func)))
2005-01-18 10:45:27 -05:00
2005-01-19 09:50:45 -05:00
(define rule-candidate-add
(lambda (rule-trans-set target prereqs wants-build? build-func)
(let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(known-rules (rule-trans-set-known-rules rule-trans-set))
(rule-set (rule-trans-set-rule-set rule-trans-set))
(rule-args (list prereqs wants-build? build-func)))
(make-rule-trans-set (alist-cons target rule-args rule-candidates)
known-rules
rule-set))))
2005-01-18 10:45:27 -05:00
2005-01-19 09:50:45 -05:00
(define (rule-candidate-del rule-trans-set target)
(let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(known-rules (rule-trans-set-known-rules rule-trans-set))
(rule-set (rule-trans-set-rule-set rule-trans-set)))
(make-rule-trans-set (alist-delete! target rule-candidates)
known-rules
rule-set)))
2005-01-18 10:45:27 -05:00
(define (rule-candidate-get rule-trans-set target)
(let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(maybe-rule-candidate (assq target rule-candidates)))
(if maybe-rule-candidate
(cons target (cdr (assq target rule-candidates)))
maybe-rule-candidate)))
;;; o if a target's prereqs are all in known-rules then the rule-candidate
;;; can be added to the known-rules as a freshly created rule
;;; o any rule-candidate with () as prereqs can be added to the known-rules
;;; as well, so this will be the first element of the known-rules
2005-01-19 09:50:45 -05:00
(define known-rules-add
(lambda (rule-trans-set target prereqs wants-build? build-func)
(let ((rule (make-rule (map (lambda (prereq)
(known-rules-get rule-trans-set prereq))
prereqs)
wants-build?
build-func))
(rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(known-rules (rule-trans-set-known-rules rule-trans-set))
(rule-set (rule-trans-set-rule-set rule-trans-set)))
(make-rule-trans-set rule-candidates
(alist-cons target rule known-rules)
(rule-set-add rule rule-set)))))
(define (known-rules-get rule-trans-set target)
(let* ((known-rules (rule-trans-set-known-rules rule-trans-set))
(maybe-rule (assoc target known-rules)))
2005-01-19 09:50:45 -05:00
(if maybe-rule (cdr maybe-rule) maybe-rule)))
2005-01-18 10:45:27 -05:00
(define (known-rules-update rts)
(let until-no-change ((last-rcs (length (rule-trans-set-rule-candidates rts)))
(rule-trans-set rts))
(let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(candidate-descs (map cons (map car rule-candidates)
(map cdr rule-candidates))))
(let for-candidates ((current-candidate-desc (car candidate-descs))
(to-do-candidate-desc (cdr candidate-descs))
(current-rts rule-trans-set))
(let ((target (list-ref current-candidate-desc 0))
(prereqs (list-ref current-candidate-desc 1))
(wants-build? (list-ref current-candidate-desc 2))
(build-func (list-ref current-candidate-desc 3)))
(let* ((known-rules (rule-trans-set-known-rules current-rts))
;;
;; if all prereqs of a target are in known-rules
;; then the rule-candidate can be added to the known-rules
;; after its deletion of the rule-candidates
;;
(new-rts (if (not (memq #f
(map (lambda (prereq)
(assoc prereq known-rules))
prereqs)))
(known-rules-add (rule-candidate-del
current-rts
target)
target prereqs
wants-build? build-func)
current-rts)))
(if (not (null? to-do-candidate-desc))
(for-candidates (car to-do-candidate-desc)
(cdr to-do-candidate-desc)
new-rts)
(let ((current-rcs (length (rule-trans-set-rule-candidates
new-rts))))
(if (or (= current-rcs last-rcs) (= current-rcs 0))
new-rts
(until-no-change current-rcs new-rts))))))))))