scsh-make/makros.scm

(define *fname->rule*-table '())
(define rule-set (make-empty-rule-set))

;;; (*fname->rule*-get fname) ---> rule
(define (*fname->rule*-get fname)
  (let ((rule-found? (assoc fname *fname->rule*-table)))
    (if rule-found? (cdr rule-found?))))

;;; (*fname->rule*-add! fname) ---> {}
(define (*fname->rule*-add! fname rule)
  (let ((rule-found? (assoc fname *fname->rule*-table)))
    (if rule-found?
	(error "There already exists a rule with this fname!")
	(begin 
	  (set! *fname->rule*-table 
		(alist-cons fname rule *fname->rule*-table))
	  (set! rule-set (rule-set-add rule rule-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-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 '() ?prereqs ?action-thunk)
     (error "Target specification in makefile-rule matches '()!"))
    ((makefile-rule (?target0 ...) ?prereqs ?action-thunk)
     (begin 
       (makefile-rule ?target0 ?prereqs ?action-thunk)
       ...))
    ((makefile-rule ?target '() ?action-thunk)
     (*fname->rule*-add! ?target
			 (make-rule '()
				    (make-is-out-of-date? ?target)
				    (lambda ?args (?action-thunk)))))
    ((makefile-rule ?target (?prereq0 ...) ?action-thunk)
     (begin 
       (*fname->rule*-add! ?target
			   (make-rule (list (*fname->rule*-get ?prereq0)
					    ...)
				      (make-is-out-of-date? ?target ?prereq0 ...)
				      (lambda ?args (?action-thunk))))))
    ((makefile-rule ?target ?prereq0 ?action-thunk)
     (*fname->rule*-add! ?target
			 (make-rule (list (*fname->rule*-get ?prereq0))
				    (make-is-out-of-date? ?target ?prereq0)
				    (lambda ?args (?action-thunk)))))))

(define-syntax with-is-out-of-date?-check-func 
  (syntax-rules ()
    ((with-is-out-of-date?-producer ?make-is-out-of-date? ?makefile-rule

(define-syntax makefile
  (syntax-rules () 
;    ((makefile ()) '())
    ((makefile ?rule0 ...)
     (begin 
       (set! rule-set (make-empty-rule-set))
       ?rule0 ...))))

(define-syntax make
  (syntax-rules ()
    ((make ?fname)
     (rule-make (*fname->rule*-get ?fname)
		"This is not an empty initial state."
		rule-set))))