aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog10
-rw-r--r--src/boot/ast.boot27
-rw-r--r--src/boot/initial-env.lisp8
-rw-r--r--src/boot/strap/ast.clisp77
-rw-r--r--src/boot/strap/tokens.clisp28
-rw-r--r--src/boot/strap/translator.clisp90
-rw-r--r--src/boot/tokens.boot8
-rw-r--r--src/boot/translator.boot7
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)