aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordos-reis <gdr@axiomatics.org>2009-09-04 03:10:47 +0000
committerdos-reis <gdr@axiomatics.org>2009-09-04 03:10:47 +0000
commit5ec566efd3ae43b1bf470e5da19de940ac95c0dd (patch)
treeeef2d0cf2cbae2993cacc5ef83033635935d6e16
parentffc2fe52c4d8f3b213e6f954ee262e9fc09b7248 (diff)
downloadopen-axiom-5ec566efd3ae43b1bf470e5da19de940ac95c0dd.tar.gz
* boot/ast.boot (bfAlternative): New. Move single assignment in
pattern matching to the body of the branch. (bfSequence): Use it.
-rw-r--r--src/ChangeLog6
-rw-r--r--src/boot/ast.boot9
-rw-r--r--src/boot/strap/ast.clisp61
-rw-r--r--src/boot/strap/translator.clisp9
4 files changed, 59 insertions, 26 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 11a82c82..de9f95f4 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,11 @@
2009-09-03 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * 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 <gdr@cs.tamu.edu>
+
* boot/ast.boot: More cleanup.
2009-09-02 Gabriel Dos Reis <gdr@cs.tamu.edu>
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