scsh-make/macros.scm

;;; 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)
     ;; 
     ;; ?rule-trans-set or ?target-fname0 could be an expr: eval only once
     ;; 
     (let ((rule-trans-set (known-rules-update ?rule-trans-set)))
       (let* ((target-fname0 ?target-fname0)
	      (target-rule (known-rules-get rule-trans-set target-fname0)))
	 (if (not (null? (rule-trans-set-rule-candidates rule-trans-set)))
	     (display "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.")))
       ...))
    ((_ ) 
     (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))
;;; 	      ...)
;;; 	 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)
     (lambda ?args
       (cons (file-not-exists? ?target) ?args)))
    ((make-is-out-of-date? ?target ?prereq0 ...)
     (lambda ?args
       (cons (and (file-exists? ?prereq0) ...
		  (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))))))