scsh-make/to-rule-set.scm

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