scsh-conservatory
/
scsh-make
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

*** empty log message ***

This commit is contained in:
jottbee 2005-01-19 14:50:45 +00:00
parent dbda21b92a
commit 5277066db6
5 changed files with 208 additions and 140 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

139
macros.scm
View File

@ -1,25 +1,95 @@
;;; TODO:
;;;
;;; macros -> functions, eg.
;;;
;;; (define make-is-out-of-date!
;;; (lambda (t . p)
;;; (lambda args (cons #t (last args)))))
(define-syntax make (define-syntax make
(syntax-rules () (syntax-rules ()
((make ?rule-trans-set (?target-fname0 ...) ?init-state) ((make ?rule-trans-set (?target-fname0 ...) ?init-state)
(begin ;;
(let ((target-rule (rule-candidate-get ?rule-trans-set ?target-fname0))) ;; ?rule-trans-set could be an expr: eval only once
(if (not (null? (rule-trans-set-rule-candidates ?rule-trans-set))) ;;
(display "warning: rule-candidates not empty!\n")) (let ((rule-trans-set ?rule-trans-set))
(let ((target-rule (known-rules-get rule-trans-set ?target-fname0)))
(if target-rule (if target-rule
(rule-make target-rule (rule-make target-rule
?init-state ?init-state
(rule-trans-set-rule-set ?rule-trans-set)) (rule-trans-set-rule-set rule-trans-set))
(error "target-rule not found in rule-set."))) (error "target-rule not found in rule-set.")))
...)))) ...))
((_ ) (error "usage: (make '#{:rule-trans-set} (target0 ...) init-state)\n"))))
(define-syntax makefile (define-syntax makefile
(syntax-rules () (syntax-rules ()
((makefile ?rule0 ...) ((makefile ?rule0 ...)
(let ((rule-trans-set (make-empty-rule-trans-set))) (let ((rule-trans-set (make-empty-rule-trans-set)))
(let ((rule-trans-set (?rule0 rule-trans-set))) (let* ((rule-trans-set (?rule0 rule-trans-set))
... ...)
rule-trans-set))))) rule-trans-set)))))
;;; (define-syntax makefile
;;; (syntax-rules ()
;;; ((makefile) (make-empty-rule-trans-set))
;;; ((makefile ?rule0 ?rule1 ...)
;;; (?rule0 (makefile ?rule1 ...)))))
(define-syntax makefile-rule
(syntax-rules ()
((makefile-rule ?target (?prereq0 ...) ?thunk)
(makefile-rule-tmpvars () ?target (?prereq0 ...) ?thunk))))
(define-syntax makefile-rule-tmpvars
(syntax-rules ()
((makefile-rule-tmpvars (tmp1 ...) ?target () ?thunk)
;;
;; ?target could be an expr: eval only once
;;
(let ((target ?target))
(lambda (rule-trans-set)
(rule-trans-set-add rule-trans-set
target
(list tmp1 ...)
(make-is-out-of-date? target tmp1 ...)
(lambda ?args (?thunk))))))
;;
;; recursively construct temporary, hygienic variables
;;
((makefile-rule-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk)
(let ((tmp2 ?prereq0))
(makefile-rule-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk)))))
(define-syntax makefile-rule-md5
(syntax-rules ()
((makefile-rule-md5 ?fingerprint ?target (?prereq0 ...) ?thunk)
(makefile-rule-md5-tmpvars () ?fingerprint ?target (?prereq0 ...) ?thunk))))
(define-syntax makefile-rule-md5-tmpvars
(syntax-rules ()
((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target () ?thunk)
;;
;; ?target could be an expr: eval only once
;;
(let ((target ?target))
(lambda (rule-trans-set)
(rule-trans-set-add rule-trans-set
target
(list tmp1 ...)
(make-has-md5-digest=? ?fingerprint
target
tmp1 ...)
(lambda ?args (?thunk))))))
;;
;; recursively construct temporary, hygienic variables
;;
((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target
(?prereq0 ?prereq1 ...) ?thunk)
(let ((tmp2 ?prereq0))
(makefile-rule-md5-tmpvars (tmp1 ... tmp2) ?fingerprint
?target (?prereq1 ...) ?thunk)))))
(define-syntax make-is-out-of-date? (define-syntax make-is-out-of-date?
(syntax-rules () (syntax-rules ()
((make-is-out-of-date? ?target) ((make-is-out-of-date? ?target)
@ -55,56 +125,3 @@
(md5-digest->number ?fingerprint))) (md5-digest->number ?fingerprint)))
(last ?args)))))) (last ?args))))))
(define-syntax makefile-rule
(syntax-rules ()
((makefile-rule ?target (?prereq0 ...) ?thunk)
(makefile-rule-tmpvars () ?target (?prereq0 ...) ?thunk))))
(define-syntax makefile-rule-tmpvars
(syntax-rules ()
((makefile-rule-tmpvars (tmp1 ...) ?target () ?thunk)
;;
;; ?target could be an expr: eval only once
;;
(let ((target ?target))
(lambda (rule-trans-set)
(rule-trans-set-add! rule-trans-set
target
(list tmp1 ...)
(make-is-out-of-date? target tmp1 ...)
(lambda ?args (?thunk))))))
;;
;; recursively construct temporary, hygienic variables
;;
((makefile-rule-tmpvars (tmp1 ...) ?target (?prereq0 ?prereq1 ...) ?thunk)
(let ((tmp2 ?prereq0))
(makefile-rule-tmpvars (tmp1 ... tmp2) ?target (?prereq1 ...) ?thunk)))))
(define-syntax makefile-rule-md5
(syntax-rules ()
((makefile-rule-md5 ?fingerprint ?target (?prereq0 ...) ?thunk)
(makefile-rule-md5-tmpvars () ?fingerprint ?target (?prereq0 ...) ?thunk))))
(define-syntax makefile-rule-md5-tmpvars
(syntax-rules ()
((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target () ?thunk)
;;
;; ?target could be an expr: eval only once
;;
(let ((target ?target))
(lambda (rule-trans-set)
(rule-trans-set-add! rule-trans-set
target
(list tmp1 ...)
(make-has-md5-digest=? ?fingerprint
target
tmp1 ...)
(lambda ?args (?thunk))))))
;;
;; recursively construct temporary, hygienic variables
;;
((makefile-rule-md5-tmpvars (tmp1 ...) ?fingerprint ?target
(?prereq0 ?prereq1 ...) ?thunk)
(let ((tmp2 ?prereq0))
(makefile-rule-md5-tmpvars (tmp1 ... tmp2) ?fingerprint
?target (?prereq1 ...) ?thunk)))))

10
make-rule.scm
View File

@ -144,17 +144,17 @@
;; initially make the connections to every prereq-listen-ch ;; initially make the connections to every prereq-listen-ch
;; ;;
(let node-loop ((tmsg (collect&reply/receive listen-ch)) (let node-loop ((tmsg (collect&reply/receive listen-ch))
(?recipients #f)) (maybe-recipients #f))
(let ((sender (tagged-msg-tag tmsg)) (let ((sender (tagged-msg-tag tmsg))
(cmd (tagged-msg-stripped tmsg))) (cmd (tagged-msg-stripped tmsg)))
(cond (cond
((eq? (rule-cmd-name cmd) 'make) ((eq? (rule-cmd-name cmd) 'make)
(if (not ?recipients) (if (not maybe-recipients)
(set! ?recipients (set! maybe-recipients
(rule-node/make-links rule connect-ch rule-set))) (rule-node/make-links rule connect-ch rule-set)))
(let ((res (rule-node/make rule listen-ch connect-ch (let ((res (rule-node/make rule listen-ch connect-ch
?recipients init-state))) maybe-recipients init-state)))
(collect&reply/send listen-ch (make-tagged-msg sender res)))) (collect&reply/send listen-ch (make-tagged-msg sender res))))
((eq? (rule-cmd-name cmd) 'shutdown) (terminate-current-thread)))) ((eq? (rule-cmd-name cmd) 'shutdown) (terminate-current-thread))))
(node-loop (collect&reply/receive listen-ch) ?recipients))) (node-loop (collect&reply/receive listen-ch) maybe-recipients)))
'rule-node))) 'rule-node)))

36
makefile.scm
View File

@ -1,24 +1,28 @@
;;; (define d (expand-file-name "~/.tmp")) ;;; (define work-dir (expand-file-name "~/.tmp"))
;;; ;;;
;;; (make
;;; (makefile ;;; (makefile
;;; (makefile-rule (expand-file-name "skills.tex" d) ;;; (makefile-rule (expand-file-name "skills.tex" work-dir)
;;; () ;;; ()
;;; (lambda () ;;; (lambda ()
;;; (with-cwd d (display "Top: skills.tex")))) ;;; (with-cwd work-dir (display "Top: skills.tex"))))
;;; (makefile-rule (expand-file-name "skills.dvi" d) ;;; (makefile-rule (expand-file-name "skills.dvi" work-dir)
;;; (expand-file-name "skills.tex" d) ;;; ((expand-file-name "skills.tex" work-dir))
;;; (lambda () ;;; (lambda ()
;;; (with-cwd d ;;; (with-cwd
;;; (run (latex ,(expand-file-name "skills.tex" d)))))) ;;; work-dir
;;; (makefile-rule (expand-file-name "skills.pdf" d) ;;; (run (latex ,(expand-file-name "skills.tex" work-dir))))))
;;; (expand-file-name "skills.dvi" d) ;;; (makefile-rule (expand-file-name "skills.pdf" work-dir)
;;; ((expand-file-name "skills.dvi" work-dir))
;;; (lambda () ;;; (lambda ()
;;; (with-cwd d (run ;;; (with-cwd
;;; work-dir
;;; (run
;;; (dvipdfm -o ;;; (dvipdfm -o
;;; ,(expand-file-name "skills.pdf" d) ;;; ,(expand-file-name "skills.pdf" work-dir)
;;; ,(expand-file-name "skills.dvi" d))))))) ;;; ,(expand-file-name "skills.dvi" work-dir)))))))
;;; ;;; ((expand-file-name "skills.pdf" work-dir))
;;; (make (expand-file-name "skills.pdf" d) "this is an empty init-state") ;;; "this is an empty init-state")
(make (make
(makefile (makefile
@ -38,5 +42,7 @@
(with-cwd "/home/bruegman/.tmp" (with-cwd "/home/bruegman/.tmp"
(run (dvipdfm -o ,"/home/bruegman/.tmp/skills.pdf" (run (dvipdfm -o ,"/home/bruegman/.tmp/skills.pdf"
,"/home/bruegman/.tmp/skills.dvi")))))) ,"/home/bruegman/.tmp/skills.dvi"))))))
("/home/bruegman/.tmp/skills.pdf") ("/home/bruegman/.tmp/skills.pdf"
"/home/bruegman/.tmp/skills.dvi"
"/home/bruegman/.tmp/skills.tex")
"this is an empty init-state...") "this is an empty init-state...")

5
packages.scm
View File

@ -189,8 +189,9 @@
rule-trans-set-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-add! rule-trans-set-add
rule-candidate-get)) rule-candidate-get
known-rules-get))
(define-structure rule-trans-set rule-trans-set-interface (define-structure rule-trans-set rule-trans-set-interface
(open scheme-with-scsh (open scheme-with-scsh

134
rule-trans-set.scm
View File

@ -1,3 +1,7 @@
;;; TODO:
;;;
;;; change to topological sort
;;; ;;;
;;; RULE-TRANS-SET ;;; RULE-TRANS-SET
;;; ;;;
@ -25,24 +29,35 @@
(rule-set (make-empty-rule-set))) (rule-set (make-empty-rule-set)))
(make-rule-trans-set rule-candidates known-rules rule-set))) (make-rule-trans-set rule-candidates known-rules rule-set)))
(define rule-trans-set-add! ;;; 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
(lambda (rule-trans-set target prereqs wants-build? build-func) (lambda (rule-trans-set target prereqs wants-build? build-func)
(let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set)) (known-rules-update
(rule-candidate-add rule-trans-set
target
prereqs
wants-build?
build-func))))
(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)) (known-rules (rule-trans-set-known-rules rule-trans-set))
(rule-set (rule-trans-set-rule-set rule-trans-set)) (rule-set (rule-trans-set-rule-set rule-trans-set))
(args (list rule-candidates target prereqs wants-build? build-func))) (rule-args (list prereqs wants-build? build-func)))
(apply rule-candidate-add! args) (make-rule-trans-set (alist-cons target rule-args rule-candidates)
(known-rules-update rule-trans-set)))) known-rules
rule-set))))
;;; o every incoming rule is considered as a rule-candidate so it is added (define (rule-candidate-del rule-trans-set target)
;;; here first (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(define rule-candidate-add! (known-rules (rule-trans-set-known-rules rule-trans-set))
(lambda (rule-candidates target prereqs wants-build? build-func) (rule-set (rule-trans-set-rule-set rule-trans-set)))
(let ((rule-args (list prereqs wants-build? build-func))) (make-rule-trans-set (alist-delete! target rule-candidates)
(set! rule-candidates (alist-cons target rule-args rule-candidates))))) known-rules
rule-set)))
(define (rule-candidate-del! rule-candidates target)
(alist-delete! target rule-candidates))
(define (rule-candidate-get rule-trans-set target) (define (rule-candidate-get rule-trans-set target)
(let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set)) (let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
@ -55,40 +70,69 @@
;;; can be added to the known-rules as a freshly created rule ;;; 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 ;;; 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 ;;; as well, so this will be the first element of the known-rules
(define (known-rules-add! rule-trans-set target prereqs wants-build? build-func) (define known-rules-add
(let ((rule (make-rule prereqs wants-build? build-func)) (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)) (rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(known-rules (rule-trans-set-known-rules rule-trans-set)) (known-rules (rule-trans-set-known-rules rule-trans-set))
(rule-set (rule-trans-set-rule-set rule-trans-set))) (rule-set (rule-trans-set-rule-set rule-trans-set)))
(set! known-rules (alist-cons target rule known-rules))
(make-rule-trans-set rule-candidates (make-rule-trans-set rule-candidates
known-rules (alist-cons target rule known-rules)
(rule-set-add rule rule-set)))) (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 (assq target known-rules)))
(if maybe-rule (cdr maybe-rule) maybe-rule)))
(define (known-rules-update rule-trans-set)
(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))
(new-rts (if (not (memq #f (map (lambda (prereq)
(assq 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)
new-rts))))))
;;; look for all rule-candidates that can be added to known-rules ;;; look for all rule-candidates that can be added to known-rules
(define (known-rules-update rule-trans-set) ;;; and add them to known-rules
(let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))) ;;; (define (known-rules-update rule-trans-set)
(map (lambda (candidate-desc) ;;; (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set)))
(apply (lambda (target prereqs wants-build? build-func) ;;; (map (lambda (candidate-desc)
(let ((rules (rule-trans-set-known-rules rule-trans-set))) ;;; (apply (lambda (target prereqs wants-build? build-func)
(if (not (memq #f (map (lambda (prereq) ;;; (let ((rules (rule-trans-set-known-rules rule-trans-set)))
(assq prereq rules)) ;;; (if (not (memq #f (map (lambda (prereq)
prereqs))) ;;; (assq prereq rules))
(begin ;;; prereqs)))
(rule-candidate-del! rule-trans-set target) ;;; (set! rule-trans-set
(set! rule-trans-set ;;; (apply known-rules-add!
(apply known-rules-add! ;;; (append (list (rule-candidate-del
(append (list rule-trans-set) ;;; rule-trans-set
candidate-desc)))) ;;; target))
rule-trans-set))) ;;; candidate-desc))))
candidate-desc)) ;;; rule-trans-set))
;; ;;; candidate-desc))
;; get the (target prereqs wants-build? build-func)-list ;;; (map cons (map car rule-candidates) (map cdr rule-candidates)))))
;; for each target
;;
(map (lambda (target)
(rule-candidate-get rule-trans-set target))
;;
;; get all targets
;;
(map car rule-candidates)))))