scsh-make/templates.scm

(define digest-extensions (list ".md5" ".fp" ".digest"))

(define (make-file-build-func target prereqs thunk)
  (lambda args 
;    (breakpoint "make-file-build-func")
    (let ((cooked-state (last args))
	  (prereqs-results (cdr (reverse (cdr args)))))
      (cons (begin 
	      (display ";;; file      : ")
	      (display target)
	      (newline)
	      (bind-fluids-gnu target prereqs prereqs-results thunk))
	    cooked-state))))

(define (make-md5-build-func target prereqs thunk)
  (lambda args 
;    (breakpoint "make-md5-build-func")
    (let ((cooked-state (last args))
	  (prereqs-results (cdr (reverse (cdr args)))))
      (cons (begin 
	      (display ";;; md5       : ")
	      (display target)
	      (newline)
	      (bind-fluids-gnu target prereqs prereqs-results thunk))
	    cooked-state))))

(define (make-always-build-func target prereqs thunk)
  (lambda args 
;    (breakpoint "make-always-build-func")
    (let ((cooked-state (last args))
	  (prereqs-results (cdr (reverse (cdr args)))))
      (cons (begin 
	      (display ";;; always    : ")
	      (display target)
	      (newline)
	      (bind-fluids-gnu target prereqs prereqs-results thunk))
	    cooked-state))))

(define (make-once-build-func target prereqs thunk)
  (lambda args 
;    (breakpoint "make-once-build-func")
    (let ((cooked-state (last args))
	  (prereqs-results (cdr (reverse (cdr args)))))
      (cons (begin 
	      (display ";;; once      : ")
	      (display target)
	      (newline)
	      (bind-fluids-gnu target prereqs prereqs-results thunk))
	    cooked-state))))

(define (make-is-out-of-date! target . prereqs)
  (lambda args 
;    (breakpoint "make-is-out-of-date!")
    (let ((init-state (last args)))
      (cons #t init-state))))

(define (make-once target . prereqs)
  (lambda args
;    (breakpoint "make-once")
    (let ((init-state (last args)))
      (cons (file-not-exists? target) init-state))))

(define (make-is-out-of-date? target . prereqs)
 (lambda args 
;    (breakpoint "make-is-out-of-date?")
    (let ((init-state (last args)))
      (cons (if (file-not-exists? target)
		#t
		(if (null? prereqs)
		    #f
		    (let ((target-mtime (file-last-mod target)))
		      (let for-each-prereq ((prereq (car prereqs))
					    (todo (cdr prereqs)))
			(cond
			 ((file-not-exists? prereq) 
			  (error "nonexistent prerequisite" prereq))
			 ((> (file-last-mod prereq) target-mtime) #t)
			 ((null? todo) #f)
			 (else (for-each-prereq (car todo) (cdr todo))))))))
	    init-state))))

(define (make-md5-sum-changed? target . prereqs)
  (lambda args 
;    (breakpoint "make-md5-sum-changed?")
    (let ((init-state (last args)))
      (cons (not (same-checksum? target digest-extensions prereqs))
	    init-state))))

(define (checksum-from-file basename extension)
  (let* ((bname (string-append basename extension))
	 (file (expand-file-name bname (cwd))))
    (if (file-exists? file)
	(let* ((outport (open-input-file file))
	       (strls (port->string-list outport)))
	  ;; (display ";;; using     : ") (display bname) (newline)
	  (if (null? strls) 
	      #f 
	      (string->number (car strls))))
	#f)))

(define (checksum-into-file basename extension checksum)
  (let* ((bname (string-append basename extension))
	 (file (expand-file-name bname (cwd)))
	 (outport (open-output-file file))
	 (str (number->string checksum)))
    ;; (display ";;; update    : ") (display bname) (newline)
    (with-current-output-port outport (begin (display str) (newline)))
    (close outport)))

(define (checksum-for-file fname)
  (let ((file (expand-file-name fname (cwd))))
    (and (file-exists? file)
	 (md5-digest->number (md5-digest-for-port (open-input-file file))))))

;;; optimizations possible: global variable with known checksums
(define (get-file-checksum fname)
  (checksum-for-file fname))

(define (same-checksum? target extensions prereqs)
  (or (null? prereqs)
      (let for-each-prereq ((current-prereq (car prereqs))
			    (previous-total 0)
			    (todo-prereqs (cdr prereqs)))
	(let* ((current-file-sum (get-file-checksum current-prereq))
	       (current-total (if current-file-sum
				  (+ current-file-sum previous-total)
				  previous-total)))
	  (cond 
	   ((and (not (null? todo-prereqs)))
	    (for-each-prereq (car todo-prereqs) 
			     current-total 
			     (cdr todo-prereqs)))
	   ((and (null? todo-prereqs) (not (null? extensions)))
	    (let for-each-ext ((ext (car extensions))
			       (todo-exts (cdr extensions)))
		(let ((known-sum (checksum-from-file target ext)))
		  (cond 
		   ((and (file-not-exists? target) known-sum)
		    (begin 
		      (checksum-into-file target ext current-total)
		      #f))
		   ((and (file-not-exists? target) (null? todo-exts))
		    (begin 
		      (checksum-into-file target 
					  (last (reverse extensions)) 
					  current-total)
		      #f))
		   ((and known-sum (= current-total known-sum)) #t)
		   ((and known-sum (not (= current-total known-sum)))
		    (begin
		      (checksum-into-file target ext current-total)
		      #f))
		   ((and (not known-sum) (not (null? todo-exts)))
		    (for-each-ext (car todo-exts) (cdr todo-exts)))
		   ((and (not known-sum) (null? todo-exts))
		    (begin 
		      (checksum-into-file target ext current-total)
		      #f))
		   (else (error "no match in same-checksum?"))))))
	   (else (error "no match in same-checksum?")))))))