Fixes for PROGV:

* Operators PROGV/PROGV-EXIT did not register referenced variables.
* Missing PROGV-EXIT operand at the end of a PROGV statement.
* The output variable of PROGV must have type 'cl_index'

src/new-cmp/cmppass.lsp

@@ -67,9 +67,8 @@
      for *current-function* = (pop pending)
      for f = *current-function*
      while f
-     do (cmpnote "Applying pass ~A on function ~A" pass f)
-     do (setf (fun-lambda f) (funcall pass f (fun-lambda f)))
-     do (setf pending (append (fun-child-funs f) pending))))
+     do (setf (fun-lambda f) (funcall pass f (fun-lambda f))
+              pending (append (fun-child-funs f) pending))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;;
@@ -201,13 +200,11 @@ forms are also suppressed."
 (defun pass-consistency (function forms)
   "We verify that all used variables that appear in a form contain this
 form in its read/set nodes, and add other consistency checks."
+  (pprint-c1forms forms)
   (labels ((in-read-set-nodes (tree form)
              (cond ((var-p tree)
                     (or (member form (var-read-nodes tree) :test #'eq)
-                        (member form (var-set-nodes tree) :test #'eq)
-                        (progn
-                          (warn "Variable ~A not referenced" (var-name tree))
-                          nil)))
+                        (member form (var-set-nodes tree) :test #'eq)))
                    ((atom tree)
                     t)
                    (t

src/new-cmp/cmptranslate.lsp

@@ -189,10 +189,15 @@
     (make-c1form* 'UNBIND :args vars close-block)))
 
 (defun c1progv-op (ndx-loc vars-loc values-loc)
-  (make-c1form* 'PROGV :args ndx-loc vars-loc values-loc))
+  (let ((form (make-c1form* 'PROGV :args ndx-loc vars-loc values-loc)))
+    (setf (var-kind ndx-loc) :CL-INDEX
+          (var-type ndx-loc) 'SI::INDEX)
+    (maybe-add-to-set-nodes ndx-loc form)
+    (maybe-add-to-read-nodes vars-loc form)
+    (maybe-add-to-read-nodes values-loc form)))
 
 (defun c1progv-exit-op (ndx-loc)
-  (make-c1form* 'PROGV-EXIT :args ndx-loc))
+  (maybe-add-to-read-nodes ndx-loc (make-c1form* 'PROGV-EXIT :args ndx-loc)))
 
 ;;;
 ;;; ASSIGNMENTS

src/new-cmp/cmputil.lsp

@@ -160,6 +160,7 @@
     (apply #'format t args)))
 
 (defun cmperr (string &rest args)
+  (error)
   (let ((c (make-condition 'compiler-error
 			   :format-control string
 			   :format-arguments args)))

src/new-cmp/cmpvar.lsp

@@ -319,7 +319,8 @@
 	  (nconc ndx-prefix
 		 prefix
 		 (c1progv-op bds-ndx (first temps) (second temps))
-		 (c1translate destination args)
+		 (c1progn destination args)
+                 (c1progv-exit-op bds-ndx)
 		 postfix
 		 ndx-postfix))))))