anchor.diff:  		  ;; this many are uninitialized
   		  (nbutlast arg-types *compiling-while-body*)
   		  arg-types)
  -	      side-effects))))      
  -
  +	      side-effects))))
  +
  +(defun bst-compile-literal-as-while-predicate (pred-literal)
  +  (let ((*form-stack* ())
  +	(*borrowed-variables* ())
  +	(*form-bindings* ()))
  +    (compile-literal pred-literal)
  +    (let ((predicate-value-form
  +	   (pop-single-value-form '(boolean)
  +				  :when-empty nil
  +				  :assigned-variables
  +				  (mapcar #'variable-name *borrowed-variables*)
  +				  :need-variable :if-side-effects)))
  +      (unless predicate-value-form
  +	(bst-compile-error "PREDICATE function ~:S~%  does not deliver a (boolean or integer) stack value; we cannot handle this"
  +			   pred-literal))
  +      (let ((num-assignments (assign-loop-variables)))
  +	(when (eql num-assignments :not-balanced)
  +	  (throw 'complicated-loop :not-balanced))
  +	(unless (zerop num-assignments)
  +	  (throw 'complicated-loop :assignments-in-predicate))
  +	(push-form predicate-value-form)
  +	(multiple-value-bind (pred-form pred-arg-types pred-res-types
  +					pred-side-effects pred-free-variables)
  +	    (package-as-form)
  +	  (declare (ignore pred-res-types))
  +	  (setq pred-side-effects
  +		(remove-variables-from-side-effects pred-free-variables pred-side-effects))
  +	  (values pred-form pred-free-variables
  +		  pred-arg-types pred-side-effects))))))
  +
  +(defun current-stack-as-values-list ()
  +  "Pop all value forms off the stack, collect them in a list suitable
  +for VALUES and push them again onto the stack.  Return two values: a
  +list of forms and a list of their types."
  +  (let ((result-mvforms '()))
  +    (loop as mvform = (pop-single-value-form t :need-variable t :when-empty nil)
  +	  while mvform
  +	  do (push mvform result-mvforms))
  +    (dolist (mvform result-mvforms)
  +      (push-form mvform))
  +    (values (mapcar #'mvform-form result-mvforms)
  +	    (mapcar (lambda (mvform)
  +		      (car (mvform-types mvform))) result-mvforms))))    
  +    
   (define-bst-special-form "while$"
       (let* ((body-literal (pop-literal))
   	   (pred-literal (pop-literal)))
  -      (multiple-value-bind (pred-form pred-arg-types
  -				      pred-res-types pred-side-effects)
  -	  (bst-compile-literal pred-literal ())
  -	(unless (null pred-arg-types)
  -	  (bst-compile-error "PREDICATE function ~S~%  takes stack values: ~S"
  -			     pred-literal pred-arg-types))
  -	(unless (and (= (length pred-res-types) 1)
  -		     (type= (car pred-res-types) '(boolean)))
  -	  (bst-compile-error "PREDICATE function ~S~%  does not deliver exactly one boolean stack value: ~S"
  -			     pred-literal pred-res-types))
  -	(multiple-value-bind (body loop-vars loop-var-types init-types
  -				   body-side-effects)
  -	    (bst-compile-literal-as-while-body body-literal)
  -	  ;; filter out locals from the list of variables assigned to
  -	  ;; in the body
  -	  (setq body-side-effects
  -		(remove-variables-from-side-effects loop-vars body-side-effects))
  -	  (let ((init-clauses
  -		 (loop for var in loop-vars
  -		       as types = init-types then (cdr types)
  -		       collect (if (null types)
  -				   var
  -				   `(,var
  -				     ,(pop-form (car types))))))
  -		(values-body
  -		 (case (length loop-var-types)
  -		   (0 ())
  -		   (1 (list (car loop-vars)))
  -		   (2 (list `(values ,@loop-vars)))))
  -		(side-effects
  -		 (max-side-effects pred-side-effects body-side-effects)))
  -	    ;; Only pred is guaranteed to execute, so:
  -	    (setf (side-effects-unconditionally-assigned-variables side-effects)
  -		  (side-effects-unconditionally-assigned-variables pred-side-effects))
  -	    (push-mvform :form `(do ,init-clauses
  -				 (,(build-not-form pred-form) ,@values-body)
  -				 ,@body)
  -			 :types loop-var-types
  -			 :side-effects side-effects)))))) 
  -
  +      (flet ((make-init-clauses (loop-vars init-types)
  +	       (loop for var in loop-vars
  +		     as types = init-types then (cdr types)
  +		     collect (if (null types)
  +				 var
  +				 `(,var ,(pop-form (car types)))))))
  +	(when
  +	    (catch 'complicated-loop
  +	      ;; Try to compile the predicate as a Lisp form
  +	      (multiple-value-bind (pred-form pred-free-variables
  +					      pred-arg-types pred-side-effects)
  +		  (bst-compile-literal-as-while-predicate pred-literal)
  +		;; Compile body
  +		(multiple-value-bind (body loop-vars loop-var-types init-types
  +					   body-side-effects)
  +		    (bst-compile-literal-as-while-body body-literal
  +						       pred-free-variables
  +						       pred-arg-types)
  +		  ;; filter out locals from the list of variables assigned to
  +		  ;; in the body
  +		  (setq body-side-effects
  +			(remove-variables-from-side-effects loop-vars body-side-effects))
  +		  (let ((init-clauses (make-init-clauses loop-vars init-types))
  +			(values-body  (build-values-body loop-vars))
  +			(side-effects
  +			 (max-side-effects pred-side-effects body-side-effects)))
  +		    ;; Only pred is guaranteed to execute, so:
  +		    (setf (side-effects-unconditionally-assigned-variables side-effects)
  +			  (side-effects-unconditionally-assigned-variables pred-side-effects))
  +		    (push-mvform :form `(do ,init-clauses
  +					 (,(build-not-form pred-form) ,@values-body)
  +					 ,@body)
  +				 :types loop-var-types
  +				 :side-effects side-effects))))
  +	      nil)
  +	  ;; Complicated loop
  +	  (multiple-value-bind (loop-form loop-vars loop-var-types
  +					  return-types side-effects)
  +	      (let ((*form-stack* ())
  +		    (*borrowed-variables* ())
  +		    (*form-bindings* ()))
  +		(compile-literal pred-literal)
  +		;; Compute the results and the side effects of the predicate
  +		(multiple-value-bind (dummy-lisp-form dummy-arg-types dummy-res-types
  +						      predicate-side-effects)
  +		    (package-as-form)
  +		  (declare (ignore dummy-lisp-form dummy-arg-types dummy-res-types))
  +		  (let* ((predicate-form (pop-single-value-form '(boolean))) 
  +			 (borrowed-variables-at-return *borrowed-variables*)
  +			 (return-form (list 'return nil))) ; will be mutated later
  +		    (multiple-value-bind (values-list-at-return types-list-at-return)
  +			(current-stack-as-values-list)
  +		      (push-mvform :form `(when ,(build-not-form
  +						  (mvform-form predicate-form))
  +					   ,return-form)
  +				   :types '()
  +				   :side-effects (max-side-effects
  +						  (mvform-side-effects predicate-form)
  +						  (make-instance 'side-effects
  +								 :side-effects-p t)))
  +		      (compile-literal body-literal)
  +		      (assign-loop-variables)
  +		      (multiple-value-bind (body arg-types res-types side-effects free-vars)
  +			  (package-as-body)
  +			(declare (ignore res-types))
  +			;; Handle the variables that have been
  +			;; borrowed after emitting the RETURN form
  +			(let* ((newly-borrowed-variables
  +				(ldiff *borrowed-variables* borrowed-variables-at-return))
  +			       (values-list
  +				(nconc (mapcar #'variable-name newly-borrowed-variables)
  +				       values-list-at-return))
  +			       (returned-types
  +				(nconc (mapcar #'variable-type newly-borrowed-variables)
  +				       types-list-at-return)))
  +			  ;; Fix the return form
  +			  (setf (cdr return-form)
  +				(build-values-body values-list))
  +			  ;; Only the predicate is guaranteed to
  +			  ;; execute
  +			  (setf (side-effects-unconditionally-assigned-variables side-effects)
  +				(side-effects-unconditionally-assigned-variables predicate-side-effects))
  +			  (values `(loop ,@body)
  +				  free-vars
  +				  arg-types
  +				  returned-types
  +				  side-effects)))))))
  +	    (setq side-effects
  +		  (remove-variables-from-side-effects loop-vars side-effects))
  +	    (push-mvform :form `(let ,(make-init-clauses loop-vars loop-var-types)
  +				 ,loop-form)
  +			 :types return-types
  +			 :side-effects side-effects))))))
   
   ;;;
   
  
positive.code:     
  
  (defun bst-compile-warning (format-string &rest args)
    (signal (make-condition 'bst-compiler-warning
  			  :message
  			  (concatenate 'string
  				       (format nil " In BST body ~S:~%  "
  					       (currently-compiled-body-with-markup))
  				       (apply 'format nil format-string args)))))
  
  (defun bst-compile-error (format-string &rest args)
    (error (make-condition 'bst-compiler-error
  
negative.code: 	  (pop-form type-1 :need-variable nil)
  	(let ((form (cond
  		      ((type= type-2 '(boolean))
  		       `(eql ,form-1 ,form-2)) ;FIXME: wrong
  		      ((type= type-2 '(integer))
  		       `(= ,form-1 ,form-2))
  		      ((type= type-2 '(string))
  