aboutsummaryrefslogtreecommitdiff
path: root/src/boot
diff options
context:
space:
mode:
Diffstat (limited to 'src/boot')
-rw-r--r--src/boot/ast.boot28
-rw-r--r--src/boot/strap/ast.clisp65
2 files changed, 30 insertions, 63 deletions
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 670ad2da..a3d84d33 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1081,22 +1081,20 @@ bfIf(a,b,c)==
bfExit(a,b)==
["COND",[a,["IDENTITY",b]]]
+bfFlattenSeq l ==
+ l = nil => l
+ [x,:xs] := l
+ x isnt [.,:.] =>
+ xs = nil => l
+ bfFlattenSeq xs
+ x.op is 'PROGN => bfFlattenSeq [:x.args,:xs]
+ [x,:bfFlattenSeq xs]
+
bfMKPROGN l==
- a := [:bfFlattenSeq c for c in tails l]
- a = nil => nil
- rest a = nil => first a
- ["PROGN",:a]
-
-bfFlattenSeq x ==
- x = nil => nil
- f := first x
- atom f =>
- rest x => nil
- [f]
- f is ["PROGN",:.] =>
- rest x => [i for i in rest f| not atom i]
- rest f
- [f]
+ l := bfFlattenSeq l
+ l = nil => nil
+ l is [.] => first l
+ ["PROGN",:l]
++ The body of each branch of a COND form is an implicit PROGN.
++ For readability purpose, we want to refrain from including
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 213414cd..03b0b55f 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -2014,57 +2014,26 @@
(DEFUN |bfExit| (|a| |b|)
(LIST 'COND (LIST |a| (LIST 'IDENTITY |b|))))
-(DEFUN |bfMKPROGN| (|l|)
- (PROG (|a|)
- (RETURN
- (PROGN
- (SETQ |a|
- (LET ((|bfVar#1| NIL) (|bfVar#2| NIL) (|c| |l|))
- (LOOP
- (COND
- ((ATOM |c|) (RETURN |bfVar#1|))
- (T (LET ((|bfVar#3|
- (|copyList| (|bfFlattenSeq| |c|))))
- (COND
- ((NULL |bfVar#3|) NIL)
- ((NULL |bfVar#1|) (SETQ |bfVar#1| |bfVar#3|)
- (SETQ |bfVar#2| (|lastNode| |bfVar#1|)))
- (T (RPLACD |bfVar#2| |bfVar#3|)
- (SETQ |bfVar#2| (|lastNode| |bfVar#2|)))))))
- (SETQ |c| (CDR |c|)))))
- (COND
- ((NULL |a|) NIL)
- ((NULL (CDR |a|)) (CAR |a|))
- (T (CONS 'PROGN |a|)))))))
-
-(DEFUN |bfFlattenSeq| (|x|)
- (PROG (|f|)
+(DEFUN |bfFlattenSeq| (|l|)
+ (PROG (|xs| |x|)
(RETURN
(COND
- ((NULL |x|) NIL)
- (T (SETQ |f| (CAR |x|))
+ ((NULL |l|) |l|)
+ (T (SETQ |x| (CAR |l|)) (SETQ |xs| (CDR |l|))
(COND
- ((ATOM |f|) (COND ((CDR |x|) NIL) (T (LIST |f|))))
- ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN))
- (COND
- ((CDR |x|)
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL)
- (|bfVar#1| (CDR |f|)) (|i| NIL))
- (LOOP
- (COND
- ((OR (ATOM |bfVar#1|)
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- (T (AND (NOT (ATOM |i|))
- (COND
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2| #0=(CONS |i| NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|)))))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
- (T (CDR |f|))))
- (T (LIST |f|))))))))
+ ((NOT (CONSP |x|))
+ (COND ((NULL |xs|) |l|) (T (|bfFlattenSeq| |xs|))))
+ ((EQ (CAR |x|) 'PROGN)
+ (|bfFlattenSeq| (|append| (CDR |x|) |xs|)))
+ (T (CONS |x| (|bfFlattenSeq| |xs|)))))))))
+
+(DEFUN |bfMKPROGN| (|l|)
+ (PROGN
+ (SETQ |l| (|bfFlattenSeq| |l|))
+ (COND
+ ((NULL |l|) NIL)
+ ((AND (CONSP |l|) (NULL (CDR |l|))) (CAR |l|))
+ (T (CONS 'PROGN |l|)))))
(DEFUN |bfWashCONDBranchBody| (|x|)
(PROG (|y|)