diff options
Diffstat (limited to 'src/boot')
| -rw-r--r-- | src/boot/ast.boot | 28 | ||||
| -rw-r--r-- | src/boot/strap/ast.clisp | 65 |
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|) |