* boot/ast.boot (bfTableIteratorBindingForm): New.

	(bfExpandTableIters): Use it.
	* boot/initial-env.lisp (HKEYS): Remove.
	* boot/tokens.boot (shoeDictCons): Iterate directly over shoeKeyTable.
	(shoePunCons): Likewise.
	* boot/translator.boot (shoeReport): Iterate directly over $bootUsed.
	(shoeXReport): Likewise.

8 files changed, 133 insertions, 122 deletions

diff --git a/src/ChangeLog b/src/ChangeLog
index 22dd7946..e3ec68bc 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,13 @@
+2011-09-30  Gabriel Dos Reis  <gdr@cs.tamu.edu>
+
+	* boot/ast.boot (bfTableIteratorBindingForm): New.
+	(bfExpandTableIters): Use it.
+	* boot/initial-env.lisp (HKEYS): Remove.
+	* boot/tokens.boot (shoeDictCons): Iterate directly over shoeKeyTable.
+	(shoePunCons): Likewise.
+	* boot/translator.boot (shoeReport): Iterate directly over $bootUsed.
+	(shoeXReport): Likewise.
+
 2011-09-29  Gabriel Dos Reis  <gdr@cs.tamu.edu>
 
 	* boot/ast.boot (bfFor): Tidy. Handle hashtable iterator forms.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 12749702..25c1b01e 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -438,6 +438,26 @@ separateIterators iters ==
     x := [iter,:x]
   [reverse! x,reverse! y]
 
+bfTableIteratorBindingForm(keyval,end?,succ) ==
+  -- FIXME: most of the repetitions below could be avoided
+  -- FIXME: with better bfIS1 implementation.
+  keyval is ['CONS,key,val] =>
+    if key is 'DOT then key := gensym()
+    if val is 'DOT then val := gensym()
+    ident? key and ident? val =>
+      ['MULTIPLE_-VALUE_-BIND,[end?,key,val],[succ]]
+    ident? key =>
+      v := gensym()
+      ['MULTIPLE_-VALUE_-BIND,[end?,key,v],[succ],bfLET(val,v)]
+    k := gensym()
+    ident? val =>
+      ['MULTIPLE_-VALUE_-BIND,[end?,k,val],[succ],bfLET(key,k)]
+    v := gensym()
+    ['MULTIPLE_-VALUE_-BIND,[end?,k,v],[succ],bfLET(key,k),bfLET(val,v)]
+  k := gensym()
+  v := gensym()
+  ['MULTIPLE_-VALUE_-BIND,[end?,k,v],[succ],bfLET(keyval,['CONS,k,v])]
+
 ++ Expand the list of table iterators into a tuple form with
 ++   (a) list of table iteration initialization
 ++   (b) for each iteration, local bindings of key value
@@ -450,12 +470,7 @@ bfExpandTableIters iters ==
     inits := [[g,t],:inits]
     x := gensym()   -- exit guard
     exits := [['NOT,x],:exits]
-    e is ['CONS,k,[CONS,v,'NIL]] and ident? k and ident? v =>
-      localBindings := [['MULTIPLE_-VALUE_-BIND,[x,k,v],[g]],:localBindings]
-    k := gensym()   -- key local var
-    v := gensym()   -- value local var
-    localBindings := [['MULTIPLE_-VALUE_-BIND,[x,k,v],[g],
-                         bfLET1(['CONS,k,['CONS,v,'NIL]],e)],:localBindings]
+    localBindings := [bfTableIteratorBindingForm(e,x,g),:localBindings]
   [inits,localBindings,exits] -- NOTE: things are returned in reverse order.
 
 bfLp1(iters,body)==
diff --git a/src/boot/initial-env.lisp b/src/boot/initial-env.lisp
index 1f050115..855ac0da 100644
--- a/src/boot/initial-env.lisp
+++ b/src/boot/initial-env.lisp
@@ -86,14 +86,6 @@
   (shoeprettyprin0 x stream) 
   (terpri stream))
 
-(defun HKEYS (table)
-  (let (keys)
-    (maphash #'(lambda (key val) 
-                 (declare (ignore val))
-                 (push key keys)) table)
-    keys))
-
-
 (defun strpos (what in start dontcare)
   (setq what (string what) in (string in))
   (if dontcare
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 71922a32..6f4c96da 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -581,9 +581,41 @@
          (SETQ |bfVar#1| (CDR |bfVar#1|))))
       (LIST (|reverse!| |x|) (|reverse!| |y|))))))
 
+(DEFUN |bfTableIteratorBindingForm| (|keyval| |end?| |succ|)
+  (PROG (|k| |v| |val| |ISTMP#2| |key| |ISTMP#1|)
+    (RETURN
+     (COND
+      ((AND (CONSP |keyval|) (EQ (CAR |keyval|) 'CONS)
+            (PROGN
+             (SETQ |ISTMP#1| (CDR |keyval|))
+             (AND (CONSP |ISTMP#1|)
+                  (PROGN
+                   (SETQ |key| (CAR |ISTMP#1|))
+                   (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+                   (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+                        (PROGN (SETQ |val| (CAR |ISTMP#2|)) T))))))
+       (COND ((EQ |key| 'DOT) (SETQ |key| (GENSYM))))
+       (COND ((EQ |val| 'DOT) (SETQ |val| (GENSYM))))
+       (COND
+        ((AND (|ident?| |key|) (|ident?| |val|))
+         (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |key| |val|) (LIST |succ|)))
+        ((|ident?| |key|) (SETQ |v| (GENSYM))
+         (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |key| |v|) (LIST |succ|)
+               (|bfLET| |val| |v|)))
+        (T (SETQ |k| (GENSYM))
+         (COND
+          ((|ident?| |val|)
+           (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |val|) (LIST |succ|)
+                 (|bfLET| |key| |k|)))
+          (T (SETQ |v| (GENSYM))
+           (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|)
+                 (|bfLET| |key| |k|) (|bfLET| |val| |v|)))))))
+      (T (SETQ |k| (GENSYM)) (SETQ |v| (GENSYM))
+       (LIST 'MULTIPLE-VALUE-BIND (LIST |end?| |k| |v|) (LIST |succ|)
+             (|bfLET| |keyval| (LIST 'CONS |k| |v|))))))))
+
 (DEFUN |bfExpandTableIters| (|iters|)
-  (PROG (|ISTMP#5| |v| |ISTMP#4| CONS |ISTMP#3| |k| |x| |g| |ISTMP#2| |t|
-         |ISTMP#1| |e| |exits| |localBindings| |inits|)
+  (PROG (|x| |g| |ISTMP#2| |t| |ISTMP#1| |e| |exits| |localBindings| |inits|)
     (RETURN
      (PROGN
       (SETQ |inits| NIL)
@@ -610,44 +642,9 @@
                  (SETQ |inits| (CONS (LIST |g| |t|) |inits|))
                  (SETQ |x| (GENSYM))
                  (SETQ |exits| (CONS (LIST 'NOT |x|) |exits|))
-                 (COND
-                  ((AND (CONSP |e|) (EQ (CAR |e|) 'CONS)
-                        (PROGN
-                         (SETQ |ISTMP#1| (CDR |e|))
-                         (AND (CONSP |ISTMP#1|)
-                              (PROGN
-                               (SETQ |k| (CAR |ISTMP#1|))
-                               (SETQ |ISTMP#2| (CDR |ISTMP#1|))
-                               (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
-                                    (PROGN
-                                     (SETQ |ISTMP#3| (CAR |ISTMP#2|))
-                                     (AND (CONSP |ISTMP#3|)
-                                          (PROGN
-                                           (SETQ CONS (CAR |ISTMP#3|))
-                                           (SETQ |ISTMP#4| (CDR |ISTMP#3|))
-                                           (AND (CONSP |ISTMP#4|)
-                                                (PROGN
-                                                 (SETQ |v| (CAR |ISTMP#4|))
-                                                 (SETQ |ISTMP#5|
-                                                         (CDR |ISTMP#4|))
-                                                 (AND (CONSP |ISTMP#5|)
-                                                      (NULL (CDR |ISTMP#5|))
-                                                      (EQ (CAR |ISTMP#5|)
-                                                          'NIL)))))))))))
-                        (|ident?| |k|) (|ident?| |v|))
-                   (SETQ |localBindings|
-                           (CONS
-                            (LIST 'MULTIPLE-VALUE-BIND (LIST |x| |k| |v|)
-                                  (LIST |g|))
-                            |localBindings|)))
-                  (T (SETQ |k| (GENSYM)) (SETQ |v| (GENSYM))
-                   (SETQ |localBindings|
-                           (CONS
-                            (LIST 'MULTIPLE-VALUE-BIND (LIST |x| |k| |v|)
-                                  (LIST |g|)
-                                  (|bfLET1|
-                                   (LIST 'CONS |k| (LIST 'CONS |v| 'NIL)) |e|))
-                            |localBindings|))))))))
+                 (SETQ |localBindings|
+                         (CONS (|bfTableIteratorBindingForm| |e| |x| |g|)
+                               |localBindings|))))))
          (SETQ |bfVar#2| (CDR |bfVar#2|))))
       (LIST |inits| |localBindings| |exits|)))))
 
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index de9d71e3..12192b72 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -92,10 +92,9 @@
       |s|))))
 
 (DEFUN |shoeDictCons| ()
-  (PROG (|d| |b| |a| |l|)
+  (PROG (|d| |b| |a|)
     (RETURN
      (PROGN
-      (SETQ |l| (HKEYS |shoeKeyTable|))
       (SETQ |d|
               (PROGN
                (SETQ |a| (MAKE-ARRAY 256))
@@ -107,34 +106,29 @@
                         (T (SETF (ELT |a| |i|) |b|)))
                   (SETQ |i| (+ |i| 1))))
                |a|))
-      (LET ((|bfVar#1| |l|) (|s| NIL))
+      (WITH-HASH-TABLE-ITERATOR (#1=#:G719 |shoeKeyTable|)
         (LOOP
-         (COND
-          ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |s| (CAR |bfVar#1|)) NIL))
-           (RETURN NIL))
-          (T (|shoeInsert| |s| |d|)))
-         (SETQ |bfVar#1| (CDR |bfVar#1|))))
+         (MULTIPLE-VALUE-BIND (#2=#:G720 |s| #:G721)
+             (#1#)
+           (COND ((NOT #2#) (RETURN NIL)) (T (|shoeInsert| |s| |d|))))))
       |d|))))
 
 (DEFPARAMETER |shoeDict| (|shoeDictCons|))
 
 (DEFUN |shoePunCons| ()
-  (PROG (|a| |listing|)
+  (PROG (|a|)
     (RETURN
      (PROGN
-      (SETQ |listing| (HKEYS |shoeKeyTable|))
       (SETQ |a| (|makeBitVector| 256))
       (LET ((|i| 0))
         (LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
               (SETQ |i| (+ |i| 1))))
-      (LET ((|bfVar#1| |listing|) (|k| NIL))
+      (WITH-HASH-TABLE-ITERATOR (#1=#:G722 |shoeKeyTable|)
         (LOOP
-         (COND
-          ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |k| (CAR |bfVar#1|)) NIL))
-           (RETURN NIL))
-          ((|shoeStartsId| (ELT |k| 0)) NIL)
-          (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1)))
-         (SETQ |bfVar#1| (CDR |bfVar#1|))))
+         (MULTIPLE-VALUE-BIND (#2=#:G723 |k| #:G724)
+             (#1#)
+           (COND ((NOT #2#) (RETURN NIL)) ((|shoeStartsId| (SCHAR |k| 0)) NIL)
+                 (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1))))))
       |a|))))
 
 (DEFPARAMETER |shoePun| (|shoePunCons|))
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 12dda96a..22d6f918 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -760,28 +760,25 @@
 
 (DEFUN |shoeReport| (|stream|)
   (PROG (|b| |a|)
-    (DECLARE (SPECIAL |$bootDefined| |$bootUsed| |$bootDefinedTwice|))
+    (DECLARE (SPECIAL |$bootDefined| |$bootDefinedTwice| |$bootUsed|))
     (RETURN
      (PROGN
       (|shoeFileLine| "DEFINED and not USED" |stream|)
       (SETQ |a|
-              (LET ((|bfVar#2| NIL)
-                    (|bfVar#3| NIL)
-                    (|bfVar#1| (HKEYS |$bootDefined|))
-                    (|i| NIL))
-                (LOOP
-                 (COND
-                  ((OR (NOT (CONSP |bfVar#1|))
-                       (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
-                   (RETURN |bfVar#2|))
-                  (T
-                   (AND (NOT (|tableValue| |$bootUsed| |i|))
-                        (COND
-                         ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS |i| NIL))
-                          (SETQ |bfVar#3| |bfVar#2|))
-                         (T (RPLACD |bfVar#3| #1#)
-                          (SETQ |bfVar#3| (CDR |bfVar#3|)))))))
-                 (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+              (WITH-HASH-TABLE-ITERATOR (#1=#:G732 |$bootDefined|)
+                (LET ((|bfVar#1| NIL) (|bfVar#2| NIL))
+                  (LOOP
+                   (MULTIPLE-VALUE-BIND (#2=#:G733 |i| |b|)
+                       (#1#)
+                     (COND ((NOT #2#) (RETURN |bfVar#1|))
+                           (T
+                            (AND (NOT |b|)
+                                 (COND
+                                  ((NULL |bfVar#1|)
+                                   (SETQ |bfVar#1| #3=(CONS |i| NIL))
+                                   (SETQ |bfVar#2| |bfVar#1|))
+                                  (T (RPLACD |bfVar#2| #3#)
+                                   (SETQ |bfVar#2| (CDR |bfVar#2|))))))))))))
       (|bootOut| (SSORT |a|) |stream|)
       (|shoeFileLine| "             " |stream|)
       (|shoeFileLine| "DEFINED TWICE" |stream|)
@@ -789,32 +786,29 @@
       (|shoeFileLine| "             " |stream|)
       (|shoeFileLine| "USED and not DEFINED" |stream|)
       (SETQ |a|
-              (LET ((|bfVar#5| NIL)
-                    (|bfVar#6| NIL)
-                    (|bfVar#4| (HKEYS |$bootUsed|))
-                    (|i| NIL))
-                (LOOP
-                 (COND
-                  ((OR (NOT (CONSP |bfVar#4|))
-                       (PROGN (SETQ |i| (CAR |bfVar#4|)) NIL))
-                   (RETURN |bfVar#5|))
-                  (T
-                   (AND (NOT (|tableValue| |$bootDefined| |i|))
-                        (COND
-                         ((NULL |bfVar#5|) (SETQ |bfVar#5| #2=(CONS |i| NIL))
-                          (SETQ |bfVar#6| |bfVar#5|))
-                         (T (RPLACD |bfVar#6| #2#)
-                          (SETQ |bfVar#6| (CDR |bfVar#6|)))))))
-                 (SETQ |bfVar#4| (CDR |bfVar#4|)))))
-      (LET ((|bfVar#7| (SSORT |a|)) (|i| NIL))
+              (WITH-HASH-TABLE-ITERATOR (#4=#:G734 |$bootUsed|)
+                (LET ((|bfVar#3| NIL) (|bfVar#4| NIL))
+                  (LOOP
+                   (MULTIPLE-VALUE-BIND (#5=#:G735 |i| |b|)
+                       (#4#)
+                     (COND ((NOT #5#) (RETURN |bfVar#3|))
+                           (T
+                            (AND (NOT |b|)
+                                 (COND
+                                  ((NULL |bfVar#3|)
+                                   (SETQ |bfVar#3| #6=(CONS |i| NIL))
+                                   (SETQ |bfVar#4| |bfVar#3|))
+                                  (T (RPLACD |bfVar#4| #6#)
+                                   (SETQ |bfVar#4| (CDR |bfVar#4|))))))))))))
+      (LET ((|bfVar#5| (SSORT |a|)) (|i| NIL))
         (LOOP
          (COND
-          ((OR (NOT (CONSP |bfVar#7|)) (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL))
+          ((OR (NOT (CONSP |bfVar#5|)) (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL))
            (RETURN NIL))
           (T (SETQ |b| (CONCAT (PNAME |i|) " is used in "))
            (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream|
                            |b|)))
-         (SETQ |bfVar#7| (CDR |bfVar#7|))))))))
+         (SETQ |bfVar#5| (CDR |bfVar#5|))))))))
 
 (DEFUN |shoeDefUse| (|s|)
   (LOOP
@@ -1047,16 +1041,28 @@
     (RETURN
      (PROGN
       (|shoeFileLine| "USED and where DEFINED" |stream|)
-      (SETQ |c| (SSORT (HKEYS |$bootUsed|)))
-      (LET ((|bfVar#1| |c|) (|i| NIL))
+      (SETQ |c|
+              (SSORT
+               (WITH-HASH-TABLE-ITERATOR (#1=#:G738 |$bootUsed|)
+                 (LET ((|bfVar#1| NIL) (|bfVar#2| NIL))
+                   (LOOP
+                    (MULTIPLE-VALUE-BIND (#2=#:G739 |k| #:G740)
+                        (#1#)
+                      (COND ((NOT #2#) (RETURN |bfVar#1|))
+                            ((NULL |bfVar#1|)
+                             (SETQ |bfVar#1| #3=(CONS |k| NIL))
+                             (SETQ |bfVar#2| |bfVar#1|))
+                            (T (RPLACD |bfVar#2| #3#)
+                             (SETQ |bfVar#2| (CDR |bfVar#2|))))))))))
+      (LET ((|bfVar#3| |c|) (|i| NIL))
         (LOOP
          (COND
-          ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+          ((OR (NOT (CONSP |bfVar#3|)) (PROGN (SETQ |i| (CAR |bfVar#3|)) NIL))
            (RETURN NIL))
           (T (SETQ |a| (CONCAT (PNAME |i|) " is used in "))
            (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream|
                            |a|)))
-         (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
+         (SETQ |bfVar#3| (CDR |bfVar#3|))))))))
 
 (DEFUN |shoeItem| (|str|)
   (PROG (|dq|)
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index cf2b05c9..e39cee89 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -149,7 +149,6 @@ shoeInsert(s,d) ==
   s
  
 shoeDictCons()==
-  l := HKEYS shoeKeyTable
   d :=
     a := newVector 256
     b := newVector 1
@@ -157,7 +156,7 @@ shoeDictCons()==
     for i in 0..255 repeat
       a.i := b
     a
-  for s in l repeat
+  for [s,:.] in entries shoeKeyTable repeat
     shoeInsert(s,d)
   d
  
@@ -165,12 +164,11 @@ shoeDict:=shoeDictCons()
  
  
 shoePunCons()==
-  listing := HKEYS shoeKeyTable
   a := makeBitVector 256
   for i in 0..255 repeat
     bitmask(a,i) := 0
-  for k in listing repeat
-    shoeStartsId k.0 => nil
+  for [k,:.] in entries shoeKeyTable repeat
+    shoeStartsId stringChar(k,0) => nil
     bitmask(a,codePoint stringChar(k,0)) := 1
   a
  
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index 0aec8e92..8904cb00 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -522,15 +522,14 @@ shoeDfu(a,fn)==
  
 shoeReport stream==
   shoeFileLine('"DEFINED and not USED",stream)
-  a:=[i for i in HKEYS $bootDefined | not tableValue($bootUsed,i)]
+  a := [i for [i,:b] in entries $bootDefined | not b]
   bootOut(SSORT a,stream)
   shoeFileLine('"             ",stream)
   shoeFileLine('"DEFINED TWICE",stream)
   bootOut(SSORT $bootDefinedTwice,stream)
   shoeFileLine('"             ",stream)
   shoeFileLine('"USED and not DEFINED",stream)
-  a:=[i for i in HKEYS $bootUsed |
-	     not tableValue($bootDefined,i)]
+  a := [i for [i,:b] in entries $bootUsed | not b]
   for i in SSORT a repeat
      b := strconc(PNAME i,'" is used in ")
      bootOutLines( SSORT tableValue($bootUsed,i),stream,b)
@@ -640,7 +639,7 @@ shoeXref(a,fn)==
  
 shoeXReport stream==
    shoeFileLine('"USED and where DEFINED",stream)
-   c:=SSORT HKEYS $bootUsed
+   c := SSORT [k for [k,:.] in entries $bootUsed]
    for i in c repeat
       a := strconc(PNAME i,'" is used in ")
       bootOutLines( SSORT tableValue($bootUsed,i),stream,a)