diff --git a/macros.scm b/macros.scm index c901a25..5669769 100644 --- a/macros.scm +++ b/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))))) diff --git a/make-rule.scm b/make-rule.scm index 7b298c4..c20b016 100644 --- a/make-rule.scm +++ b/make-rule.scm @@ -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))) diff --git a/makefile.scm b/makefile.scm index 3d5834e..2704789 100644 --- a/makefile.scm +++ b/makefile.scm @@ -1,24 +1,28 @@ -;;; (define d (expand-file-name "~/.tmp")) +;;; (define work-dir (expand-file-name "~/.tmp")) ;;; -;;; (makefile -;;; (makefile-rule (expand-file-name "skills.tex" d) -;;; () -;;; (lambda () -;;; (with-cwd d (display "Top: skills.tex")))) -;;; (makefile-rule (expand-file-name "skills.dvi" d) -;;; (expand-file-name "skills.tex" d) -;;; (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) -;;; (lambda () -;;; (with-cwd d (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") +;;; (make +;;; (makefile +;;; (makefile-rule (expand-file-name "skills.tex" work-dir) +;;; () +;;; (lambda () +;;; (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 +;;; 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 +;;; work-dir +;;; (run +;;; (dvipdfm -o +;;; ,(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") - "this is an empty init-state...") + ("/home/bruegman/.tmp/skills.pdf" + "/home/bruegman/.tmp/skills.dvi" + "/home/bruegman/.tmp/skills.tex") + "this is an empty init-state...") diff --git a/packages.scm b/packages.scm index 0ed26cc..15e0e88 100644 --- a/packages.scm +++ b/packages.scm @@ -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 diff --git a/rule-trans-set.scm b/rule-trans-set.scm index ab59c81..d5cedd4 100644 --- a/rule-trans-set.scm +++ b/rule-trans-set.scm @@ -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 (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)))) + (known-rules-update + (rule-candidate-add rule-trans-set + target + prereqs + wants-build? + build-func)))) -;;; 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-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)))) -(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)) - (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)))) +(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 (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))))) +