(define (sequence-phases datum phase-alist)
  (if (null? phase-alist)
      (begin
	(when (debug-mode=? 'sequence-phases)
	  (display ";; Final phase result is ")
	  (write (node->list datum))
	  (newline))
	datum)
      (let* ((entry (car phase-alist))
	     (phase-name (car entry))
	     (phase-prelanguage (cadr entry))
	     (phase-body (caddr entry))
	     (phase-postlanguage (cadddr entry))
	     (rest (cdr phase-alist)))
	(when (debug-mode=? 'sequence-phases)
	  (display ";;--------------------------------------------------")
	  (newline)
	  (display ";; Applying phase \"")
	  (display phase-name)
	  (display "\" to ")
	  (write (node->list datum))
	  (newline))
	(when (not (apply-validator phase-prelanguage datum))
	  (error (string-append "Failed precondition for phase \"" phase-name "\"")
		 datum))
	(let ((new-datum (phase-body datum)))
	  (when (not (apply-validator phase-postlanguage new-datum))
	    (error (string-append "Failed postcondition for phase \"" phase-name "\"")
		   new-datum))
	  (sequence-phases new-datum rest)))))

(define (compiler-front-end-phases expr)
  (sequence-phases
   expr
   (list
    (list "macro-expansion"			%any macro-expand %core-scheme)
    (list "toplevel begin-flattening"		%core-scheme flatten-begins %core-scheme)
    (list "toplevel-rewriting"			%core-scheme rewrite-toplevel-defines %core-scheme)
    (list "wrapping in outer lambda"		%core-scheme wrap-outer-lambda %core-scheme)
    (list "internal-definition-rewriting"	%core-scheme rewrite-internal-definitions %ds)
    (list "opt(1) removing head thunks"		%ds remove-thunk-in-head-position %ds)
    (list "cps-transform"			%ds cps-transform %cps-value)
    (list "opt(2) removing noop begins"		%cps-value remove-begin-head-noops %cps-value)
    (list "annotation"				%cps-value annotate-root %cps2-value))))
