diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 10 | ||||
| -rw-r--r-- | src/boot/ast.boot | 27 | ||||
| -rw-r--r-- | src/boot/initial-env.lisp | 8 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 77 | ||||
| -rw-r--r-- | src/boot/strap/tokens.clisp | 28 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 90 | ||||
| -rw-r--r-- | src/boot/tokens.boot | 8 | ||||
| -rw-r--r-- | src/boot/translator.boot | 7 |
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) |