scsh-make/macros.scm

(define-syntax makefile
  (syntax-rules (pred)
    ((makefile ?clauses ...)
     (let ((id=? string=?))
       (clauses->lists id=? () () ?clauses ...)))
    ((makefile (pred id=?) ?clauses ...)
       (clauses->lists id=? () () ?clauses ...))))

(define-syntax clauses->lists
  (syntax-rules (common-% common-rx)
    ((clauses->lists pred (?rc0 ...) (?func1 ...) (common-% ?%0 ...) ?clause1 ...)
     (clauses->lists pred 
		     (?rc0 ...) 
		     (?func1 ... (common-%-clause->func pred ?%0) ...)
		     ?clause1 ...))
    ((clauses->lists pred (?rc0 ...) (?func1 ...) (common-rx ?rx0 ...) ?clause1 ...)
     (clauses->lists pred 
		     (?rc0 ...) 
		     (?func1 ... (common-rx-clause->func pred ?rx0) ...)
		     ?clause1 ...))
    ((clauses->lists pred (?rc1 ...) (?func0 ...) ?clause0 ?clause1 ...)
     (clauses->lists pred 
		     (?rc1 ... (clause->rc pred ?clause0)) 
		     (?func0 ...) 
		     ?clause1 ...))
    ((clauses->lists pred (?rc0 ...) (?func0 ...))
      (rcs+commons->rules pred 
			  (list ?rc0 ...) 
			  (list ?func0 ...)))))

(define-syntax common-rx-clause->func
  (syntax-rules () 
    ((common-rx-clause->func pred 
			     (?out-of-date?-func ?target-rx 
						 (?prereq-pattern0 ...) 
						 ?action0 ...))
     (lambda (maybe-target)
       (let ((target-rx ?target-rx))
	 (common-clause->func maybe-target
			      target-rx 
			      pred
			      (?out-of-date?-func ?target-rx 
						  (?prereq-pattern0 ...) 
						  ?action0 ...)))))))

(define-syntax common-%-clause->func
  (syntax-rules () 
    ((common-%-clause->func pred
			    (?out-of-date?-func ?target-pattern 
						(?prereq-pattern0 ...) 
						?action0 ...))
     (lambda (maybe-target)
       (let* ((pattern ?target-pattern)
	      (left (common-%-pattern->match pattern 1))
	      (middle (common-%-pattern->match pattern 2))
	      (right (common-%-pattern->match pattern 3))
	      (target-rx (if (string=? "%" middle)
			     (rx (: (submatch (: bos ,left))
				    (submatch (* any))
				    (submatch (: ,right eos))))
			     (rx (: (submatch (: bos ,left))
				    (submatch ,middle)
				    (submatch (: ,right eos)))))))
	 (common-clause->func maybe-target 
			      target-rx 
			      pred
			      (?out-of-date?-func ?target-pattern
						  (?prereq-pattern0 ...)
						  ?action0 ...)))))))

(define-syntax common-%-pattern->match
  (syntax-rules () 
    ((common-%-pattern->match ?target-pattern ?no)
     (match:substring (regexp-search (rx (: (submatch (: bos (* any)))
					    (submatch "%") 
					    (submatch (: (* any) eos))))
				     ?target-pattern)
		      ?no))))

(define-syntax common-s/%/match
  (syntax-rules () 
    ((common-s/%/match ?pattern ?match)
     (regexp-substitute/global 
      #f (rx (: (submatch (: bos (* any)))
		(submatch "%") 
		(submatch (: (* any) eos)))) ?pattern 'pre 1 ?match 3 'post))))

(define-syntax common-clause->func
  (syntax-rules () 
    ((common-clause->func maybe-target 
			  target-rx 
			  pred
			  (?out-of-date?-func ?target-pattern 
					      (?prereq-pattern0 ...) 
					      ?action0 ...))
     (let* ((match-data (regexp-search target-rx maybe-target))
	    (maybe-target-matches (if match-data 
				      (map (lambda (no)
					     (match:substring match-data no))
					   (list 1 2 3))
				      #f)))
       (if maybe-target-matches
	   (let* ((left (list-ref maybe-target-matches 0))
		  (target-match (list-ref maybe-target-matches 1))
		  (right (list-ref maybe-target-matches 2))
		  (target-name (string-append left target-match right))
		  (prereqs (list ?prereq-pattern0 ...))
		  (cooked-prereqs (map (lambda (prereq) 
					 (if (string? prereq)
					     (common-s/%/match prereq target-match)
					     prereq))
				       prereqs)))
	     (list target-name
		   cooked-prereqs
		   ;;out-to-date?-func 
		   (lambda args 
		     (let ((init-state (last args)))
		       (cons (bind-fluids-common 
			      target-name left target-match right
			      (lambda () 
				(?out-of-date?-func target-name 
						    cooked-prereqs)))
			     init-state)))
		   ;; build-func 
		   (lambda args 
		     (let ((cooked-state (last args))
			   (prereqs-results (cdr (reverse (cdr args)))))
		       (cons (bind-fluids-common 
			      target-name left target-match right
			      (lambda () 
				(bind-all-fluids target-name 
						 cooked-prereqs 
						 prereqs-results 
						 (lambda () ?action0 ...))))
			     cooked-state)))))
	   #f)))))

(define-syntax clause->rc
  (syntax-rules ()
    ((clause->rc pred (?func ?target (?prereq0 ...) ?action0 ...))
     (clause->rc-tmp () pred (?func ?target (?prereq0 ...) ?action0 ...)))))

(define-syntax clause->rc-tmp
  (syntax-rules ()
    ((clause->rc-tmp (tmp1 ...) pred (?func ?target () ?action0 ...))
     (let ((target ?target)
	   (prereqs (list tmp1 ...)))
       (list target 
	     prereqs 
	     (lambda args 
	       (let ((init-state (last args)))
		 (cons (?func target (list tmp1 ...))
		       init-state)))
	     (lambda args 
	       (let ((cooked-state (last args))
		     (results (cdr (reverse (cdr args)))))
		 (cons (bind-all-fluids target prereqs results 
					(lambda () ?action0 ...))
		       cooked-state))))))
    ((clause->rc-tmp (tmp1 ...) 
		     pred 
		     (?func ?target (?prereq0 ?prereq1 ...) ?action0 ...))
     (let ((tmp2 ?prereq0))
       (clause->rc-tmp (tmp1 ... tmp2) 
		       pred 
		       (?func ?target (?prereq1 ...) ?action0 ...))))))