From 5ec566efd3ae43b1bf470e5da19de940ac95c0dd Mon Sep 17 00:00:00 2001 From: dos-reis Date: Fri, 4 Sep 2009 03:10:47 +0000 Subject: * boot/ast.boot (bfAlternative): New. Move single assignment in pattern matching to the body of the branch. (bfSequence): Use it. --- src/ChangeLog | 6 ++++ src/boot/ast.boot | 9 ++++-- src/boot/strap/ast.clisp | 61 +++++++++++++++++++++++++++++------------ src/boot/strap/translator.clisp | 9 ++---- 4 files changed, 59 insertions(+), 26 deletions(-) (limited to 'src') diff --git a/src/ChangeLog b/src/ChangeLog index 11a82c82..de9f95f4 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,9 @@ +2009-09-03 Gabriel Dos Reis + + * boot/ast.boot (bfAlternative): New. Move single assignment in + pattern matching to the body of the branch. + (bfSequence): Use it. + 2009-09-03 Gabriel Dos Reis * boot/ast.boot: More cleanup. diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 1fdeceb7..f455cc3b 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -980,9 +980,14 @@ bfWashCONDBranchBody x == x is ["PROGN",:y] => y [x] +bfAlternative(a,b) == + a is ["AND",:conds,["PROGN",stmt,='T]] => + [["AND",:conds], :bfWashCONDBranchBody bfMKPROGN [stmt,b]] + [a,:bfWashCONDBranchBody b] + bfSequence l == null l=> NIL - transform:= [[a,:bfWashCONDBranchBody b] for x in l while + transform:= [bfAlternative(a,b) for x in l while x is ["COND",[a,["IDENTITY",b]]]] no:=#transform before:= bfTake(no,l) @@ -993,7 +998,7 @@ bfSequence l == f bfMKPROGN [first l,bfSequence rest l] null aft => ["COND",:transform] - ["COND",:transform,['T,:bfWashCONDBranchBody bfSequence aft]] + ["COND",:transform,bfAlternative('T,bfSequence aft)] bfWhere (context,expr)== [opassoc,defs,nondefs] := defSheepAndGoats context diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp index cc73c41e..cf2067e7 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -210,9 +210,8 @@ (COND ((NULL |x|) (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) - (PROGN (SETQ |a| (CDR |y|)) T)) - (LIST '&REST (CONS 'QUOTE |a|))) + ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE)) + (SETQ |a| (CDR |y|)) (LIST '&REST (CONS 'QUOTE |a|))) (T (LIST '&REST |y|)))) (T (CONS (CAR |x|) (|bfColonAppend| (CDR |x|) |y|))))))) @@ -282,8 +281,8 @@ (PROGN (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#2|)) T))))) - (PROGN (SETQ |l1| (CDR |l|)) T)) + (PROGN (SETQ |a| (CAR |ISTMP#2|)) T)))))) + (SETQ |l1| (CDR |l|)) (COND (|l1| (LIST 'APPEND |a| (|bfMakeCons| |l1|))) (T |a|))) (T (LIST 'CONS (CAR |l|) (|bfMakeCons| (CDR |l|)))))))) @@ -1014,8 +1013,8 @@ (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) (EQ (CAR |ISTMP#2|) 'T))))) - (CONSP |b1|) (EQ (CAR |b1|) 'PROGN) - (PROGN (SETQ |cls| (CDR |b1|)) T)) + (CONSP |b1|) (EQ (CAR |b1|) 'PROGN)) + (SETQ |cls| (CDR |b1|)) (|bfAND| (LIST (LIST 'CONSP |lhs|) (|bfMKPROGN| (CONS |c| |cls|))))) (T (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|))))))) @@ -1704,11 +1703,40 @@ (PROG (|y|) (RETURN (COND - ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN) - (PROGN (SETQ |y| (CDR |x|)) T)) + ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN)) (SETQ |y| (CDR |x|)) |y|) (T (LIST |x|)))))) +(DEFUN |bfAlternative| (|a| |b|) + (PROG (|conds| |ISTMP#5| |stmt| |ISTMP#4| |ISTMP#3| |ISTMP#2| + |ISTMP#1|) + (RETURN + (COND + ((AND (CONSP |a|) (EQ (CAR |a|) 'AND) + (PROGN + (SETQ |ISTMP#1| (CDR |a|)) + (AND (CONSP |ISTMP#1|) + (PROGN (SETQ |ISTMP#2| (REVERSE |ISTMP#1|)) T) + (CONSP |ISTMP#2|) + (PROGN + (SETQ |ISTMP#3| (CAR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CAR |ISTMP#3|) 'PROGN) + (PROGN + (SETQ |ISTMP#4| (CDR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (PROGN + (SETQ |stmt| (CAR |ISTMP#4|)) + (SETQ |ISTMP#5| (CDR |ISTMP#4|)) + (AND (CONSP |ISTMP#5|) + (EQ (CDR |ISTMP#5|) NIL) + (EQ (CAR |ISTMP#5|) 'T))))))) + (PROGN (SETQ |conds| (CDR |ISTMP#2|)) T) + (PROGN (SETQ |conds| (NREVERSE |conds|)) T)))) + (CONS (CONS 'AND |conds|) + (|bfWashCONDBranchBody| (|bfMKPROGN| (LIST |stmt| |b|))))) + (T (CONS |a| (|bfWashCONDBranchBody| |b|))))))) + (DEFUN |bfSequence| (|l|) (PROG (|f| |aft| |before| |no| |transform| |b| |ISTMP#5| |ISTMP#4| |ISTMP#3| |a| |ISTMP#2| |ISTMP#1|) @@ -1757,8 +1785,7 @@ T)))))))))))))) (RETURN (NREVERSE |bfVar#113|))) (T (SETQ |bfVar#113| - (CONS (CONS |a| - (|bfWashCONDBranchBody| |b|)) + (CONS (|bfAlternative| |a| |b|) |bfVar#113|)))) (SETQ |bfVar#112| (CDR |bfVar#112|))))) (SETQ |no| (LENGTH |transform|)) @@ -1767,8 +1794,8 @@ (COND ((NULL |before|) (COND - ((AND (CONSP |l|) (EQ (CDR |l|) NIL) - (PROGN (SETQ |f| (CAR |l|)) T)) + ((AND (CONSP |l|) (EQ (CDR |l|) NIL)) + (SETQ |f| (CAR |l|)) (COND ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN)) (|bfSequence| (CDR |f|))) @@ -1778,9 +1805,8 @@ ((NULL |aft|) (CONS 'COND |transform|)) (T (CONS 'COND (APPEND |transform| - (CONS (CONS 'T - (|bfWashCONDBranchBody| - (|bfSequence| |aft|))) + (CONS (|bfAlternative| 'T + (|bfSequence| |aft|)) NIL)))))))))) (DEFUN |bfWhere| (|context| |expr|) @@ -1884,8 +1910,7 @@ (PROG (|a| |f|) (RETURN (COND - ((AND (CONSP |x|) (EQ (CDR |x|) NIL) - (PROGN (SETQ |f| (CAR |x|)) T)) + ((AND (CONSP |x|) (EQ (CDR |x|) NIL)) (SETQ |f| (CAR |x|)) (LIST 'DEFCONSTANT |f| (LIST 'LIST (LIST 'QUOTE |f|)))) (T (SETQ |a| (LET ((|bfVar#117| NIL) (|bfVar#116| (CDR |x|)) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index c243fe0c..bb464915 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -579,8 +579,7 @@ (RETURN (COND ((ATOM |b|) (LIST |b|)) - ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE) - (PROGN (SETQ |xs| (CDR |b|)) T)) + ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE)) (SETQ |xs| (CDR |b|)) (|coreError| "invalid AST")) (T (CASE (CAR |b|) (|%Signature| @@ -947,11 +946,9 @@ (T (HPUT |$bootDefined| |i| T))) (SETQ |bfVar#20| (CDR |bfVar#20|)))) (|defuse1| (APPEND |ndol| |e|) |b|)) - ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE) - (PROGN (SETQ |a| (CDR |y|)) T)) + ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE)) (SETQ |a| (CDR |y|)) NIL) - ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE) - (PROGN (SETQ |a| (CDR |y|)) T)) + ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE)) (SETQ |a| (CDR |y|)) NIL) (T (LET ((|bfVar#21| |y|) (|i| NIL)) (LOOP -- cgit v1.2.3