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-18 15:45:27 +00:00
parent 3e19944116
commit af7d20c1b2
2 changed files with 195 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

106
macros.scm Normal file
View File

@ -0,0 +1,106 @@
(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"))
(if (?target-rule)
(rule-make ?target-rule
init-state
(rule-trans-set-rule-set ?rule-trans-set))
(error "target-rule not found in rule-set.")))
...))))
(define-syntax makefile
(syntax-rules ()
((makefile ?rule0 ...)
(let ((rule-trans-set (make-empty-rule-trans-set)))
((?rule0) rule-trans-set) ...))))
(define-syntax make-is-out-of-date?
(syntax-rules ()
((make-is-out-of-date? ?target)
(lambda ?args
(cons (file-not-exists? ?target) ?args)))
((make-is-out-of-date? ?target ?prereq0 ...)
(lambda ?args
(cons (or (file-not-exists? ?target)
(> (file-last-mod ?prereq0)
(file-last-mod ?target))
...)
(last ?args))))))
(define-syntax make-is-out-of-date!
(syntax-rules ()
((make-is-out-of-date? ?target ?prereq0 ...)
(lambda ?args
(cons #t (last ?args))))))
(define-syntax make-has-md5-digest=?
(syntax-rules ()
((make-has-md5-digest=? ?fingerprint ?target)
(lambda ?args
(cons (or (file-not-exists? ?target)
(=? (md5-digest-for-port (open-input-file ?target))
?fingerprint))
?args)))
((make-has-md5-digest=? ?fingerprint ?target ?prereq0 ...)
(lambda ?args
(cons (or (file-not-exists? ?target)
(=? (md5-digest->number (md5-digest-for-port
(open-input-file ?target)))
(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)))))

89
rule-trans-set.scm Normal file
View File

@ -0,0 +1,89 @@
;;;
;;; RULE-TRANS-SET
;;;
;;; (make-empty-rule-trans-set) ---> rule-trans-set
;;;
;;; (make-rule-trans-set rule-candidates known-rules rule-set)
;;;
;;; (rule-trans-set-rule-candidates rts) ---> (rule-candidate0 ...)
;;; (rule-trans-set-known-rules rts) ---> (known-rule0 ...)
;;; (rule-trans-set-rule-set rts) ---> rule-set
;;;
;;; (rule-trans-set-add! rule-trans-set target prereqs wants-build? build-func)
;;; ---> rule-trans-set
;;;
(define-record-type :rule-trans-set
(make-rule-trans-set rule-candidates known-rules rule-set)
is-rule-trans-set?
(rule-candidates rule-trans-set-rule-candidates)
(known-rules rule-trans-set-known-rules)
(rule-set rule-trans-set-rule-set))
(define (make-empty-rule-trans-set)
(let ((rule-candidates '())
(known-rules (alist-cons '() '() '()))
(rule-set (make-empty-rule-set)))
(make-rule-trans-set rule-candidates known-rules rule-set)))
(define (rule-trans-set-add! 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-candidate-add! rule-candidates target prereqs wants-build? build-func)
(known-rules-update rule-trans-set)))
;;; o every incoming rule is considered as a rule-candidate so it is added
;;; here first
(define (rule-candidate-add! rule-candidates target prereqs wants-build? build-func)
(set! rule-candidates
(alist-cons target (list prereqs wants-build? build-func))))
(define (rule-candidate-del! rule-candidates target)
(alist-delete! target rule-candidates))
(define (rule-candidate-get rule-trans-set target)
(let* ((rule-candidates (rule-trans-set-rule-candidates rule-trans-set))
(maybe-rule-candidate (assq target rule-candidates)))
(if maybe-rule-candidate
(cons target (cdr (assq target rule-candidates)))
maybe-rule-candidate)))
;;; o if a target's prereqs are all in known-rules then the rule-candidate
;;; 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))
(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))
(rule-set-add rule rule-set)))
;;; 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))
(known-rules (rule-trans-set-known-rules rule-trans-set))
(rule-set (rule-trans-set-rule-set rule-trans-set)))
(map (lambda (candidate-desc)
;;
;; candidate-desc is a list with these four elements
;; target prereqs wants-build? build-func
;;
(apply (lambda (target prereqs wants-build? build-func)
(if (not (memq #f (map (lambda (prereq)
(assq prereq known-rules))
prereqs)))
(rule-candidate-del! rule-trans-set target)
(apply known-rules-add! (append (list rule-trans-set)
candidate-desc))))
candidate-desc))
;;
;; get the (target prereqs wants-build? build-func)-list
;; for each target
;;
(map rule-candidate-get
;;
;; get all targets
;;
(map car rule-candidates)))
(make-rule-trans-set rule-candidates known-rules rule-set)))