*** empty log message ***
This commit is contained in:
jottbee
parent
dbda21b92a
commit
5277066db6
139
macros.scm
139
macros.scm
|
|
@ -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
|
||||
(syntax-rules ()
|
||||
((make ?rule-trans-set (?target-fname0 ...) ?init-state)
|
||||
(begin
|
||||
(let ((target-rule (rule-candidate-get ?rule-trans-set ?target-fname0)))
|
||||
(if (not (null? (rule-trans-set-rule-candidates ?rule-trans-set)))
|
||||
(display "warning: rule-candidates not empty!\n"))
|
||||
;;
|
||||
;; ?rule-trans-set could be an expr: eval only once
|
||||
;;
|
||||
(let ((rule-trans-set ?rule-trans-set))
|
||||
(let ((target-rule (known-rules-get rule-trans-set ?target-fname0)))
|
||||
(if target-rule
|
||||
(rule-make target-rule
|
||||
?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 "usage: (make '#{:rule-trans-set} (target0 ...) init-state)\n"))))
|
||||
|
||||
(define-syntax makefile
|
||||
(syntax-rules ()
|
||||
((makefile ?rule0 ...)
|
||||
(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)))))
|
||||
|
||||
;;; (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?
|
||||
(syntax-rules ()
|
||||
((make-is-out-of-date? ?target)
|
||||
|
|
@ -55,56 +125,3 @@
|
|||
(md5-digest->number ?fingerprint)))
|
||||
(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)))))
|
||||
|
|
|
|||
|
|
@ -144,17 +144,17 @@
|
|||
;; initially make the connections to every prereq-listen-ch
|
||||
;;
|
||||
(let node-loop ((tmsg (collect&reply/receive listen-ch))
|
||||
(?recipients #f))
|
||||
(maybe-recipients #f))
|
||||
(let ((sender (tagged-msg-tag tmsg))
|
||||
(cmd (tagged-msg-stripped tmsg)))
|
||||
(cond
|
||||
((eq? (rule-cmd-name cmd) 'make)
|
||||
(if (not ?recipients)
|
||||
(set! ?recipients
|
||||
(if (not maybe-recipients)
|
||||
(set! maybe-recipients
|
||||
(rule-node/make-links rule connect-ch rule-set)))
|
||||
(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))))
|
||||
((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)))
|
||||
|
|
|
|||
36
makefile.scm
36
makefile.scm
|
|
@ -1,24 +1,28 @@
|
|||
;;; (define d (expand-file-name "~/.tmp"))
|
||||
;;; (define work-dir (expand-file-name "~/.tmp"))
|
||||
;;;
|
||||
;;; (make
|
||||
;;; (makefile
|
||||
;;; (makefile-rule (expand-file-name "skills.tex" d)
|
||||
;;; (makefile-rule (expand-file-name "skills.tex" work-dir)
|
||||
;;; ()
|
||||
;;; (lambda ()
|
||||
;;; (with-cwd d (display "Top: skills.tex"))))
|
||||
;;; (makefile-rule (expand-file-name "skills.dvi" d)
|
||||
;;; (expand-file-name "skills.tex" d)
|
||||
;;; (with-cwd work-dir (display "Top: skills.tex"))))
|
||||
;;; (makefile-rule (expand-file-name "skills.dvi" work-dir)
|
||||
;;; ((expand-file-name "skills.tex" work-dir))
|
||||
;;; (lambda ()
|
||||
;;; (with-cwd d
|
||||
;;; (run (latex ,(expand-file-name "skills.tex" d))))))
|
||||
;;; (makefile-rule (expand-file-name "skills.pdf" d)
|
||||
;;; (expand-file-name "skills.dvi" d)
|
||||
;;; (with-cwd
|
||||
;;; work-dir
|
||||
;;; (run (latex ,(expand-file-name "skills.tex" work-dir))))))
|
||||
;;; (makefile-rule (expand-file-name "skills.pdf" work-dir)
|
||||
;;; ((expand-file-name "skills.dvi" work-dir))
|
||||
;;; (lambda ()
|
||||
;;; (with-cwd d (run
|
||||
;;; (with-cwd
|
||||
;;; work-dir
|
||||
;;; (run
|
||||
;;; (dvipdfm -o
|
||||
;;; ,(expand-file-name "skills.pdf" d)
|
||||
;;; ,(expand-file-name "skills.dvi" d)))))))
|
||||
;;;
|
||||
;;; (make (expand-file-name "skills.pdf" d) "this is an empty init-state")
|
||||
;;; ,(expand-file-name "skills.pdf" work-dir)
|
||||
;;; ,(expand-file-name "skills.dvi" work-dir)))))))
|
||||
;;; ((expand-file-name "skills.pdf" work-dir))
|
||||
;;; "this is an empty init-state")
|
||||
|
||||
(make
|
||||
(makefile
|
||||
|
|
@ -38,5 +42,7 @@
|
|||
(with-cwd "/home/bruegman/.tmp"
|
||||
(run (dvipdfm -o ,"/home/bruegman/.tmp/skills.pdf"
|
||||
,"/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...")
|
||||
|
|
|
|||
|
|
@ -189,8 +189,9 @@
|
|||
rule-trans-set-rule-candidates
|
||||
rule-trans-set-known-rules
|
||||
rule-trans-set-rule-set
|
||||
rule-trans-set-add!
|
||||
rule-candidate-get))
|
||||
rule-trans-set-add
|
||||
rule-candidate-get
|
||||
known-rules-get))
|
||||
|
||||
(define-structure rule-trans-set rule-trans-set-interface
|
||||
(open scheme-with-scsh
|
||||
|
|
|
|||
|
|
@ -1,3 +1,7 @@
|
|||
;;; TODO:
|
||||
;;;
|
||||
;;; change to topological sort
|
||||
|
||||
;;;
|
||||
;;; RULE-TRANS-SET
|
||||
;;;
|
||||
|
|
@ -25,24 +29,35 @@
|
|||
(rule-set (make-empty-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)
|
||||
(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))
|
||||
(rule-set (rule-trans-set-rule-set rule-trans-set))
|
||||
(args (list rule-candidates target prereqs wants-build? build-func)))
|
||||
(apply rule-candidate-add! args)
|
||||
(known-rules-update 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))))
|
||||
|
||||
;;; o every incoming rule is considered as a rule-candidate so it is added
|
||||
;;; here first
|
||||
(define rule-candidate-add!
|
||||
(lambda (rule-candidates target prereqs wants-build? build-func)
|
||||
(let ((rule-args (list prereqs wants-build? build-func)))
|
||||
(set! rule-candidates (alist-cons target rule-args rule-candidates)))))
|
||||
|
||||
(define (rule-candidate-del! rule-candidates target)
|
||||
(alist-delete! target rule-candidates))
|
||||
(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)))
|
||||
|
||||
(define (rule-candidate-get rule-trans-set target)
|
||||
(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
|
||||
;;; 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
|
||||
(define (known-rules-add! rule-trans-set target prereqs wants-build? build-func)
|
||||
(let ((rule (make-rule prereqs wants-build? build-func))
|
||||
(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)))
|
||||
(set! known-rules (alist-cons target rule known-rules))
|
||||
(make-rule-trans-set rule-candidates
|
||||
known-rules
|
||||
(rule-set-add rule rule-set))))
|
||||
(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 (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
|
||||
(define (known-rules-update rule-trans-set)
|
||||
(let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set)))
|
||||
(map (lambda (candidate-desc)
|
||||
(apply (lambda (target prereqs wants-build? build-func)
|
||||
(let ((rules (rule-trans-set-known-rules rule-trans-set)))
|
||||
(if (not (memq #f (map (lambda (prereq)
|
||||
(assq prereq rules))
|
||||
prereqs)))
|
||||
(begin
|
||||
(rule-candidate-del! rule-trans-set target)
|
||||
(set! rule-trans-set
|
||||
(apply known-rules-add!
|
||||
(append (list rule-trans-set)
|
||||
candidate-desc))))
|
||||
rule-trans-set)))
|
||||
candidate-desc))
|
||||
;;
|
||||
;; get the (target prereqs wants-build? build-func)-list
|
||||
;; for each target
|
||||
;;
|
||||
(map (lambda (target)
|
||||
(rule-candidate-get rule-trans-set target))
|
||||
;;
|
||||
;; get all targets
|
||||
;;
|
||||
(map car rule-candidates)))))
|
||||
;;; and add them to known-rules
|
||||
;;; (define (known-rules-update rule-trans-set)
|
||||
;;; (let ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set)))
|
||||
;;; (map (lambda (candidate-desc)
|
||||
;;; (apply (lambda (target prereqs wants-build? build-func)
|
||||
;;; (let ((rules (rule-trans-set-known-rules rule-trans-set)))
|
||||
;;; (if (not (memq #f (map (lambda (prereq)
|
||||
;;; (assq prereq rules))
|
||||
;;; prereqs)))
|
||||
;;; (set! rule-trans-set
|
||||
;;; (apply known-rules-add!
|
||||
;;; (append (list (rule-candidate-del
|
||||
;;; rule-trans-set
|
||||
;;; target))
|
||||
;;; candidate-desc))))
|
||||
;;; rule-trans-set))
|
||||
;;; candidate-desc))
|
||||
;;; (map cons (map car rule-candidates) (map cdr rule-candidates)))))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue