From bf22bf374fbea0275ba9617af2b7490cc9ee98df Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@jjgr-2.local>
Date: Sun, 27 Dec 2009 17:31:53 +0100
Subject: [PATCH] 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      | 11 ++++-------
 src/new-cmp/cmptranslate.lsp |  9 +++++++--
 src/new-cmp/cmputil.lsp      |  1 +
 src/new-cmp/cmpvar.lsp       |  3 ++-
 4 files changed, 14 insertions(+), 10 deletions(-)

diff --git a/src/new-cmp/cmppass.lsp b/src/new-cmp/cmppass.lsp
index d46995980..89d309a98 100644
--- a/src/new-cmp/cmppass.lsp
+++ b/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
diff --git a/src/new-cmp/cmptranslate.lsp b/src/new-cmp/cmptranslate.lsp
index 69b63f0c3..c68fcee75 100644
--- a/src/new-cmp/cmptranslate.lsp
+++ b/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
diff --git a/src/new-cmp/cmputil.lsp b/src/new-cmp/cmputil.lsp
index 22ee7b48d..cc647a8d7 100644
--- a/src/new-cmp/cmputil.lsp
+++ b/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)))
diff --git a/src/new-cmp/cmpvar.lsp b/src/new-cmp/cmpvar.lsp
index 2b95ea795..3851646d8 100644
--- a/src/new-cmp/cmpvar.lsp
+++ b/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))))))