anchor.diff:  
   (defun compute-location-indices (program)
     (let ((*program* program)
  -	(indexes (make-hash-table :test #'eq)))
  +	(indices (make-hash-table :test #'eq)))
       (with-accessors ((procedures procedures))
   	program
         (loop for procedure in procedures
  -	    do (setf (gethash procedure indexes) 0))
  +	    do (setf (gethash procedure indices) 0))
         (map-locations (lambda (location)
   		       (setf (index location)
  -			     (gethash (procedure location) indexes))
  -		       (incf (gethash (procedure location) indexes)))))))
  -
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
  -;;; Determine pre-locations and post-locations for each instruction.
  -;;;
  -;;; In this context, a FUTURE SET is a list of CONS cells.  The CAR
  -;;; of each CONS cell is a location, and the CDR is a non-negative
  -;;; integer indicating the distance (in number of instructions) to the
  -;;; next use of the location.  Each location can be present at most
  -;;; once in the list.  
  -
  -(defun future-sets-equal-p (set1 set2)
  -  (and (= (length set1) (length set2))
  -       (null (set-difference set1 set2 :test #'equal))
  -       (null (set-difference set2 set1 :test #'equal))))
  -
  -(defun combine-future-sets (set1 set2)
  -  (let ((result '()))
  -    (loop for element in (append set1 set2)
  -	  do (let ((existing (find (car element) result :key #'car :test #'eq)))
  -	       (if (null existing)
  -		   (push element result)
  -		   (setf (cdr existing)
  -			 (min (cdr existing) (cdr element))))))
  -    result))
  -
  -(defun pre-from-post (instruction)
  -  (let ((in-locations (mapcar #'sicl-env:location (inputs instruction)))
  -	(out-locations (mapcar #'sicl-env:location (outputs instruction))))
  -    (let ((result (post-locations instruction)))
  -      ;; Remove the locations that are created by this instruction.
  -      (loop for out in out-locations
  -	    do (setf result (remove out result :key #'car)))
  -      ;; Increment the distance of the remaining ones.
  -      (loop for location in result
  -	    do (incf (cdr location)))
  -      ;; Combine with inputs.
  -      (setf (pre-locations instruction)
  -	    (combine-future-sets
  -	     result
  -	     (loop for in in in-locations
  -		   collect (cons in 0)))))))
  -
  -(defun compute-pre-post-locations (program)
  -  (ensure-instruction-ownership program)
  -  (let ((*program* program))
  -    (let ((worklist '()))
  -      ;; Start by putting every instruction on the worklist.
  -      (map-instructions (lambda (instruction)
  -			  (push instruction worklist)))
  -      (loop until (null worklist)
  -	    for instruction = (pop worklist)
  -	    do (pre-from-post instruction)
  -	       (loop with pre = (pre-locations instruction)
  -		     for pred in (predecessors instruction)
  -		     for post = (post-locations pred)
  -		     for combined = (combine-future-sets pre post)
  -		     do (unless (future-sets-equal-p post combined)
  -			  (setf (post-locations pred)
  -				combined)
  -			  (unless (member pred worklist :test #'eq)
  -			    (if (= (length (successors pred)) 1)
  -				(push pred worklist)
  -				(setf worklist
  -				      (append worklist (list pred)))))))))))
  -			  
  -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  -;;;
  -;;;
  -
  -(defclass assignment ()
  -  ((%free-regs :initarg :free-regs :reader free-regs)
  -   ;; A list of CONS cells (location . reg).
  -   (%in-regs :initarg :in-regs :reader in-regs)
  -   ;; A list of CONS cells (location . pos).
  -   (%on-stack :initarg :on-stack :reader on-stack)))
  -
  -(defun make-assignment (free-regs in-regs on-stack)
  -  (make-instance 'assignment
  -    :free-regs free-regs
  -    :in-regs in-regs
  -    :on-stack on-stack))
  -
  -;;; From a particular assignment and a future set, return two values:
  -;;; a new assignment which has at least one free register in it, and
  -;;; either a save instrution or nil if no saving is necessary.
  -(defun free-up-a-register (assignment future)
  -  (with-accessors ((free-regs free-regs)
  -		   (in-regs in-regs)
  -		   (on-stack on-stack))
  -      assignment
  -    (if (null free-regs)
  -	(let ((location-reg nil))
  -	  (loop with max = 0
  -		for loc in in-regs
  -		for time = (cdr (find (car loc) future :test #'eq :key #'car))
  -		do (when (> time max)
  -		     (setf max time)
  -		     (setf location-reg loc)))
  -	  ;; Check whether the location found is also on the stack
  -	  (if (member (car location-reg) on-stack :test #'eq :key #'car)
  -	      ;; If it is, then no saving is necessary.
  -	      (values 
  -	       (make-assignment (list (cdr location-reg))
  -				(remove location-reg in-regs :test #'eq)
  -				on-stack)
  -	       nil)
  -	      ;; If not, we need to save it.
  -	      (let ((pos (loop for pos from 0
  -			       unless (member pos on-stack :key #'cdr)
  -				 return pos)))
  -		(values
  -		 (make-assignment (list (cdr location-reg))
  -				  (remove location-reg in-regs :test #'eq)
  -				  (cons (cons (car location-reg) pos) on-stack))
  -		 `(save ,(cdr location-reg) ,pos)))))
  -	(values assignment nil))))
  -		 
  -;;; From a particular assignment, return two values: a new assignment
  -;;; in which all registers are free and a list of save instructions or
  -;;; nil if no saving is necessary.
  -(defun free-all-registers (assignment)
  -  (with-accessors ((free-regs free-regs)
  -		   (in-regs in-regs)
  -		   (on-stack on-stack))
  -      assignment
  -    (let ((instructions '())
  -	  (new-stack on-stack))
  -      (loop for loc in in-regs
  -	    do (unless (member (car loc) new-stack :test #'eq :key #'car)
  -		 (let ((pos (loop for pos from 0
  -				  unless (member pos new-stack :key #'cdr)
  -				    return pos)))
  -		   (push `(save ,(cdr loc) . ,pos) instructions)
  -		   (push `(,(car loc) . ,pos) new-stack))))
  -      (values
  -       (make-assignment (append (mapcar #'cdr in-regs) free-regs)
  -			'()
  -			new-stack)
  -       instructions))))
  -	  
  -;;; From a particular assignment and a future set, return a new
  -;;; assignment that is filtred so that only locations in the future
  -;;; set are on the stack or in registers.
  -(defun filter-assignment (assignment future)
  -  (with-accessors ((free-regs free-regs)
  -		   (in-regs in-regs)
  -		   (on-stack on-stack))
  -      assignment
  -    (let ((new-free-regs free-regs)
  -	  (new-in-regs '())
  -	  (new-stack '()))
  -      (loop for loc in in-regs
  -	    do (if (member (car loc) future :test #'eq :key #'car)
  -		   (push loc new-in-regs)
  -		   (push (cdr loc) new-free-regs)))
  -      (loop for loc in on-stack
  -	    do (when (member (car loc) future :test #'eq :key #'car)
  -		 (push loc new-stack)))
  -      (make-assignment new-free-regs
  -		       new-in-regs
  -		       new-stack))))
  -
  -;;; From a paricular assignment and a location, return two values: a
  -;;; new assignment in which the location is in a register and a list
  -;;; of load and store instructions required to obtain the new
  -;;; assignment.
  -;; (defun ensure-location-in-register (assignment location)
  -;;   (with-accessors ((free-regs free-regs)
  -;; 		   (in-regs in-regs)
  -;; 		   (on-stack on-stack))
  -;;       assignment
  -;;     (cond ((member location in-regs :test #:eq :key #'car)
  -;; 	   (values assignment nil))
  -;; 	  ((
  +			     (gethash (procedure location) indices))
  +		       (incf (gethash (procedure location) indices)))))))
  +
  +(defun ensure-location-indices (program)
  +  (when (>= (ensure-instruction-ownership program)
  +	    (location-indices-timestamp program))
  +    (compute-location-indices program)
  +    (setf (location-indices-timestamp program)
  +	  (incf (current-timestamp program))))
  +  (location-indices-timestamp program))
   
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;;
  
positive.code: ;;; also referred to by some procedure C inside which both A and B are
  ;;; nested.
  ;;;
  ;;; A lexical location L is said to be PRESENT in a procedure A if and
  ;;; only if some instruction belonging to A refers to L.  A location L
  ;;; is said to BELONG to a procedure A if L is present in A, and L is
  ;;; not present in a procedure inside which A is nested.  Because of
  ;;; the restriction in the previous paragraph, every location belongs
  ;;; to some unique procedure.
  ;;;
  ;;; The LEXICAL DEPTH of a procedure is a quantity that is less than
  ;;; or equal to the NESTING depth of that procedure.  We define it
  
negative.code:       (let ((sorted-code
  	      (sort (copy-list procedures) #'< :key #'nesting-depth)))
  	(loop for procedure in sorted-code
  	      do (compute-lexical-depth procedure))))))
  
  (defun ensure-lexical-depths (program)
    (when (>= (ensure-location-ownership program)
  	    (lexical-depths-timestamp program))
      (compute-lexical-depths program)
      (setf (lexical-depths-timestamp program)
  	  (incf (current-timestamp program))))
    (lexical-depths-timestamp program))
  
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;;
  