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) (define (error-if-nonexistant target)
(error "file (assumed leaf) doesn't exist:" target)) (error "file (assumed leaf) doesn't exist:" target))
(define (match-all-func default-target) (define (match-all-func will-be-target)
(list default-target (make-rule-cand will-be-target
(list) (list)
(lambda args (lambda args
(let ((target (car args)) (let ((target (car args))
(init-state (last args))) (init-state (last args)))
(cons (file-not-exists? default-target) init-state))) (cons (file-not-exists? will-be-target) init-state)))
(lambda args (lambda args
(let ((target (car args)) (let ((target (car args))
(cooked-state (last args))) (cooked-state (last args)))
(error-if-nonexistant target))))) (error-if-nonexistant target)))))
(define (add-common-rules common-rules func) (define (add-common-rules common-rules func)
(make-common-rules (cons func (common-rules-ls common-rules)))) (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) (cons (really-make-dfs name adjs (color black) time ignored)
(delete current-node current-dag))))) (delete current-node current-dag)))))
(define (dfs-dag-show dag node) (define (dfs-dag-show dag . maybe-arg)
(newline) (newline) (newline) (newline) (let-optionals maybe-arg ((node (make-dfs "show dag" '() #f)))
(display "************************************************************\n") (newline) (newline) (newline) (newline)
(display (dfs-name node)) (newline) (display "************************************************************\n")
(display "************************************************************\n") (display (dfs-name node)) (newline)
(let ((dfs-node-show (lambda (node) (display "************************************************************\n")
(newline) (let ((dfs-node-show (lambda (node)
(display "~dfs-name: ") (newline)
(display (dfs-name node)) (display "~dfs-name: ")
(newline) (display (dfs-name node))
(display "~dfs-adjacencies: ") (newline)
(display (dfs-adjacencies node)) (display "~dfs-adjacencies: ")
(newline) (display (dfs-adjacencies node))
(display "~dfs-color: ") (newline)
(display (dfs-color node)) (display "~dfs-color: ")
(newline) (display (dfs-color node))
(display "~dfs-ftime: ") (newline)
(display (dfs-ftime node)) (display "~dfs-ftime: ")
(newline) (display (dfs-ftime node))
(display "~dfs-ignored: ") (newline)
(display (dfs-ignored node)) (display "~dfs-ignored: ")
(newline)))) (display (dfs-ignored node))
(if (not (null? dag)) (newline))))
(let visit-each-node ((current-node (car dag)) (if (not (null? dag))
(nodes-to-do (cdr dag))) (let visit-each-node ((current-node (car dag))
(dfs-node-show current-node) (nodes-to-do (cdr dag)))
(if (not (null? nodes-to-do)) (dfs-node-show current-node)
(visit-each-node (car nodes-to-do) (cdr nodes-to-do)) (if (not (null? nodes-to-do))
(begin (visit-each-node (car nodes-to-do) (cdr nodes-to-do))
(display "************************************************************\n") (newline)))))))
(display "************************************************************\n")
(newline) (newline) (newline) (newline)))))))

77
macros.scm
View File

@ -24,9 +24,9 @@
(?func0 ...) (?func0 ...)
?clause1 ...)) ?clause1 ...))
((clauses->lists pred (?rc0 ...) (?func0 ...)) ((clauses->lists pred (?rc0 ...) (?func0 ...))
(rcs+commons->rules pred (rcs+commons->rules pred
(list ?rc0 ...) (list ?rc0 ...)
(list ?func0 ...))))) (list ?func0 ...)))))
(define-syntax common-rx-clause->func (define-syntax common-rx-clause->func
(syntax-rules () (syntax-rules ()
@ -110,29 +110,30 @@
(common-s/%/match prereq target-match) (common-s/%/match prereq target-match)
prereq)) prereq))
prereqs))) prereqs)))
(list target-name (make-rule-cand target-name
cooked-prereqs cooked-prereqs
;;out-to-date?-func ;;out-to-date?-func
(lambda args (lambda args
(let ((init-state (last args))) (let ((init-state (last args)))
(cons (bind-fluids-common (cons (bind-fluids-common
target-name left target-match right target-name left target-match right
(lambda () (lambda ()
(?out-of-date?-func target-name (?out-of-date?-func target-name
cooked-prereqs))) cooked-prereqs)))
init-state))) init-state)))
;; build-func ;; build-func
(lambda args (lambda args
(let ((cooked-state (last args)) (let ((cooked-state (last args))
(prereqs-results (cdr (reverse (cdr args))))) (prereqs-results (cdr (reverse (cdr args)))))
(cons (bind-fluids-common (cons (bind-fluids-common
target-name left target-match right target-name left target-match right
(lambda () (lambda ()
(bind-all-fluids target-name (bind-all-fluids target-name
cooked-prereqs cooked-prereqs
prereqs-results prereqs-results
(lambda () ?action0 ...)))) (lambda ()
cooked-state))))) ?action0 ...))))
cooked-state)))))
#f))))) #f)))))
(define-syntax clause->rc (define-syntax clause->rc
@ -145,18 +146,18 @@
((clause->rc-tmp (tmp1 ...) pred (?func ?target () ?action0 ...)) ((clause->rc-tmp (tmp1 ...) pred (?func ?target () ?action0 ...))
(let ((target ?target) (let ((target ?target)
(prereqs (list tmp1 ...))) (prereqs (list tmp1 ...)))
(list target (make-rule-cand target
prereqs prereqs
(lambda args (lambda args
(let ((init-state (last args))) (let ((init-state (last args)))
(cons (?func target (list tmp1 ...)) (cons (?func target (list tmp1 ...))
init-state))) init-state)))
(lambda args (lambda args
(let ((cooked-state (last args)) (let ((cooked-state (last args))
(results (cdr (reverse (cdr args))))) (results (cdr (reverse (cdr args)))))
(cons (bind-all-fluids target prereqs results (cons (bind-all-fluids target prereqs results
(lambda () ?action0 ...)) (lambda () ?action0 ...))
cooked-state)))))) cooked-state))))))
((clause->rc-tmp (tmp1 ...) ((clause->rc-tmp (tmp1 ...)
pred pred
(?func ?target (?prereq0 ?prereq1 ...) ?action0 ...)) (?func ?target (?prereq0 ?prereq1 ...) ?action0 ...))

24
packages.scm
View File

@ -181,6 +181,7 @@
(open scheme-with-scsh (open scheme-with-scsh
srfi-1 srfi-1
to-rule-set to-rule-set
rule-cand
dfs dfs
autovars autovars
templates templates
@ -199,9 +200,11 @@
(define-structure to-rule-set to-rule-set-interface (define-structure to-rule-set to-rule-set-interface
(open scheme-with-scsh (open scheme-with-scsh
srfi-1 srfi-1
srfi-9
templates templates
make-rule make-rule
common-rules common-rules
rule-cand
dfs) dfs)
(files to-rule-set)) (files to-rule-set))
@ -298,20 +301,33 @@
(files autovars)) (files autovars))
(define-interface common-rules-interface (define-interface common-rules-interface
(export make-empty-common-rules (export common-rcs->common-rules
make-empty-common-rules
add-common-rules add-common-rules
search-match-in-common-rules search-match-in-common-rules))
common-rcs->common-rules))
(define-structure common-rules common-rules-interface (define-structure common-rules common-rules-interface
(open scheme-with-scsh (open scheme-with-scsh
autovars autovars
srfi-1 srfi-1
srfi-9 srfi-9
; big-util rule-cand
srfi-13) srfi-13)
(files common-rules)) (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) (define-structure make (export make)
(open scheme-with-scsh (open scheme-with-scsh
srfi-1 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) (define (paranoid target prereqs)
(not (same-checksum? target digest-extensions prereqs))) (not (same-checksum? target digest-extensions prereqs)))

40
to-rule-set.scm
View File

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