From 83bcceb281c2de61a83142e49093a985379347db Mon Sep 17 00:00:00 2001
From: dos-reis <gdr@axiomatics.org>
Date: Thu, 4 Aug 2011 21:04:51 +0000
Subject: 	* boot/ast.boot (bfFlattenSeq): Rewrite. 	(bfMKPROGN):
 Tidy.

---
 src/boot/ast.boot        | 28 ++++++++++-----------
 src/boot/strap/ast.clisp | 65 +++++++++++++-----------------------------------
 2 files changed, 30 insertions(+), 63 deletions(-)

(limited to 'src/boot')

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|)
-- 
cgit v1.2.3