diff options
author | dos-reis <gdr@axiomatics.org> | 2009-08-30 12:05:47 +0000 |
---|---|---|
committer | dos-reis <gdr@axiomatics.org> | 2009-08-30 12:05:47 +0000 |
commit | d7aca7e90f3579181f67804f7ac7ba0da4eb44d9 (patch) | |
tree | 486137c9a458f69051f730fd70d3199f435b81ac /src/boot | |
parent | 9fecfc240728b7953537c2a2c837f7a420c274af (diff) | |
download | open-axiom-d7aca7e90f3579181f67804f7ac7ba0da4eb44d9.tar.gz |
* boot/ast.boot (bfSequence): Simplify COND branch bodies.
Diffstat (limited to 'src/boot')
-rw-r--r-- | src/boot/ast.boot | 19 | ||||
-rw-r--r-- | src/boot/strap/ast.clisp | 1407 | ||||
-rw-r--r-- | src/boot/strap/includer.clisp | 293 | ||||
-rw-r--r-- | src/boot/strap/parser.clisp | 159 | ||||
-rw-r--r-- | src/boot/strap/scanner.clisp | 146 | ||||
-rw-r--r-- | src/boot/strap/translator.clisp | 357 |
6 files changed, 1089 insertions, 1292 deletions
diff --git a/src/boot/ast.boot b/src/boot/ast.boot index 0d8c17a8..13a813e0 100644 --- a/src/boot/ast.boot +++ b/src/boot/ast.boot @@ -995,22 +995,27 @@ bfFlattenSeq x == rest f [f] +++ The body of each branch of a COND form is an implicit PROGN. +++ For readability purpose, we want to refrain from including +++ any explicit PROGN. +bfWashCONDBranchBody x == + x is ["PROGN",:y] => y + [x] + bfSequence l == null l=> NIL - transform:= [[a,b] for x in l while + transform:= [[a,:bfWashCONDBranchBody b] for x in l while x is ["COND",[a,["IDENTITY",b]]]] no:=#transform before:= bfTake(no,l) aft := bfDrop(no,l) null before => - null rest l => - f:=first l - if EQCAR(f,"PROGN") - then bfSequence rest f - else f + l is [f] => + f is ["PROGN",:.] => bfSequence rest f + f bfMKPROGN [first l,bfSequence rest l] null aft => ["COND",:transform] - ["COND",:transform,['(QUOTE T),bfSequence aft]] + ["COND",:transform,['(QUOTE T),:bfWashCONDBranchBody 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 3e30419e..64b6779a 100644 --- a/src/boot/strap/ast.clisp +++ b/src/boot/strap/ast.clisp @@ -307,22 +307,15 @@ (COND ((ATOM |lhs|) (|bfINON| (LIST OP |lhs| |whole|))) (#1='T - (PROGN - (SETQ |lhs| - (COND - ((|bfTupleP| |lhs|) (CADR |lhs|)) - (#0# |lhs|))) - (COND - ((EQCAR |lhs| 'L%T) - (PROGN - (SETQ G (CADR |lhs|)) - (APPEND (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G (CADDR |lhs|)))))) - (#1# - (PROGN - (SETQ G (|bfGenSymbol|)) - (APPEND (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G |lhs|))))))))))))) + (SETQ |lhs| + (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) (#0# |lhs|))) + (COND + ((EQCAR |lhs| 'L%T) (SETQ G (CADR |lhs|)) + (APPEND (|bfINON| (LIST OP G |whole|)) + (|bfSuchthat| (|bfIS| G (CADDR |lhs|))))) + (#1# (SETQ G (|bfGenSymbol|)) + (APPEND (|bfINON| (LIST OP G |whole|)) + (|bfSuchthat| (|bfIS| G |lhs|))))))))))) (DEFUN |bfSTEP| (|id| |fst| |step| |lst|) (PROG (|suc| |ex| |pred| |final| |g2| |inc| |g1| |initval| |initvar|) @@ -346,9 +339,8 @@ (COND ((NULL |lst|) NIL) ((INTEGERP |inc|) - (PROGN - (SETQ |pred| (COND ((MINUSP |inc|) '<) (#0# '>))) - (LIST (LIST |pred| |id| |final|)))) + (SETQ |pred| (COND ((MINUSP |inc|) '<) (#0# '>))) + (LIST (LIST |pred| |id| |final|))) ('T (LIST (LIST 'COND (LIST (LIST 'MINUSP |inc|) @@ -492,9 +484,8 @@ (PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T)))) (|bf0APPEND| |a| |itl|)) ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) - (PROGN - (SETQ |newBody| (|bfConstruct| |y|)) - (|bf0APPEND| |newBody| |itl|))) + (SETQ |newBody| (|bfConstruct| |y|)) + (|bf0APPEND| |newBody| |itl|)) ('T (|bf0COLLECT| |y| |itl|)))))) (DEFUN |bf0COLLECT| (|y| |itl|) (|bfListReduce| 'CONS |y| |itl|)) @@ -575,13 +566,11 @@ (COND ((EQCAR |itl| 'ITERATORS) (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) - ('T - (PROGN - (SETQ |iters| (CDR |itl|)) - (|bfLpCross| - (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) - (CDR |iters|)) - |body|))))))) + ('T (SETQ |iters| (CDR |itl|)) + (|bfLpCross| + (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) + (CDR |iters|)) + |body|)))))) (DEFUN |bfOpReduce| (|op| |init| |y| |itl|) (PROG (|extrait| |g1| |body| |g|) @@ -658,12 +647,10 @@ (RETURN (COND ((NULL |p|) |e|) - (#0='T - (PROGN - (SETQ |f| (CAR |p|)) - (COND - ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|))) - (#0# (|bfSUBLIS1| (CDR |p|) |e|))))))))) + (#0='T (SETQ |f| (CAR |p|)) + (COND + ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|))) + (#0# (|bfSUBLIS1| (CDR |p|) |e|)))))))) (DEFUN |defSheepAndGoats| (|x|) (PROG (|defstack| |op1| |opassoc| |argl|) @@ -724,48 +711,37 @@ (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)))) (|bfLetForm| |lhs| |rhs|)) ((AND (IDENTP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|))) - (PROGN - (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) - (COND - ((EQCAR |rhs1| 'L%T) (|bfMKPROGN| (LIST |rhs1| |rhs|))) - ((EQCAR |rhs1| 'PROGN) (APPEND |rhs1| (LIST |rhs|))) - (#0='T - (PROGN - (COND - ((IDENTP (CAR |rhs1|)) - (SETQ |rhs1| (CONS |rhs1| NIL)))) - (|bfMKPROGN| (APPEND |rhs1| (CONS |rhs| NIL)))))))) + (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) + (COND + ((EQCAR |rhs1| 'L%T) (|bfMKPROGN| (LIST |rhs1| |rhs|))) + ((EQCAR |rhs1| 'PROGN) (APPEND |rhs1| (LIST |rhs|))) + (#0='T + (COND + ((IDENTP (CAR |rhs1|)) (SETQ |rhs1| (CONS |rhs1| NIL)))) + (|bfMKPROGN| (APPEND |rhs1| (CONS |rhs| NIL)))))) ((AND (CONSP |rhs|) (EQCAR |rhs| 'L%T) (IDENTP (SETQ |name| (CADR |rhs|)))) - (PROGN - (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) - (SETQ |l2| (|bfLET1| |lhs| |name|)) - (COND - ((EQCAR |l2| 'PROGN) (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) - (#0# - (PROGN - (COND - ((IDENTP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) - (|bfMKPROGN| - (CONS |l1| (APPEND |l2| (CONS |name| NIL))))))))) + (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) + (SETQ |l2| (|bfLET1| |lhs| |name|)) + (COND + ((EQCAR |l2| 'PROGN) (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) + (#0# + (COND ((IDENTP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) + (|bfMKPROGN| (CONS |l1| (APPEND |l2| (CONS |name| NIL))))))) (#0# - (PROGN - (SETQ |g| - (INTERN (CONCAT "LETTMP#" - (STRINGIMAGE |$letGenVarCounter|)))) - (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) - (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) - (SETQ |let1| (|bfLET1| |lhs| |g|)) - (COND - ((EQCAR |let1| 'PROGN) - (|bfMKPROGN| (CONS |rhs1| (CDR |let1|)))) - (#0# - (PROGN - (COND - ((IDENTP (CAR |let1|)) - (SETQ |let1| (CONS |let1| NIL)))) - (|bfMKPROGN| - (CONS |rhs1| (APPEND |let1| (CONS |g| NIL))))))))))))) + (SETQ |g| + (INTERN (CONCAT "LETTMP#" + (STRINGIMAGE |$letGenVarCounter|)))) + (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) + (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) + (SETQ |let1| (|bfLET1| |lhs| |g|)) + (COND + ((EQCAR |let1| 'PROGN) + (|bfMKPROGN| (CONS |rhs1| (CDR |let1|)))) + (#0# + (COND + ((IDENTP (CAR |let1|)) (SETQ |let1| (CONS |let1| NIL)))) + (|bfMKPROGN| (CONS |rhs1| (APPEND |let1| (CONS |g| NIL))))))))))) (DEFUN |bfCONTAINED| (|x| |y|) (COND @@ -796,13 +772,12 @@ (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0='T)))))) - (PROGN - (SETQ |a| (|bfLET2| |a| |rhs|)) - (COND - ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) - ((ATOM |b|) (LIST |a| |b|)) - ((CONSP (CAR |b|)) (CONS |a| |b|)) - (#1='T (LIST |a| |b|))))) + (SETQ |a| (|bfLET2| |a| |rhs|)) + (COND + ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) + ((ATOM |b|) (LIST |a| |b|)) + ((CONSP (CAR |b|)) (CONS |a| |b|)) + (#1='T (LIST |a| |b|)))) ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'CONS) (PROGN (SETQ |ISTMP#1| (CDR |lhs|)) @@ -817,30 +792,26 @@ (AND (CONSP |var1|) (EQCAR |var1| 'QUOTE))) (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) (#1# - (PROGN - (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) - (COND - ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) - (#1# - (PROGN - (COND - ((AND (CONSP |l1|) (ATOM (CAR |l1|))) - (SETQ |l1| (CONS |l1| NIL)))) - (COND - ((IDENTP |var2|) - (APPEND |l1| - (CONS (|bfLetForm| |var2| - (|addCARorCDR| 'CDR |rhs|)) - NIL))) - (#1# - (PROGN - (SETQ |l2| - (|bfLET2| |var2| - (|addCARorCDR| 'CDR |rhs|))) - (COND - ((AND (CONSP |l2|) (ATOM (CAR |l2|))) - (SETQ |l2| (CONS |l2| NIL)))) - (APPEND |l1| |l2|))))))))))) + (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) + (COND + ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) + (#1# + (COND + ((AND (CONSP |l1|) (ATOM (CAR |l1|))) + (SETQ |l1| (CONS |l1| NIL)))) + (COND + ((IDENTP |var2|) + (APPEND |l1| + (CONS (|bfLetForm| |var2| + (|addCARorCDR| 'CDR |rhs|)) + NIL))) + (#1# + (SETQ |l2| + (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) + (COND + ((AND (CONSP |l2|) (ATOM (CAR |l2|))) + (SETQ |l2| (CONS |l2| NIL)))) + (APPEND |l1| |l2|)))))))) ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'APPEND) (PROGN (SETQ |ISTMP#1| (CDR |lhs|)) @@ -850,44 +821,43 @@ (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) (PROGN (SETQ |var2| (CAR |ISTMP#2|)) #0#)))))) - (PROGN - (SETQ |patrev| (|bfISReverse| |var2| |var1|)) - (SETQ |rev| (LIST 'REVERSE |rhs|)) - (SETQ |g| - (INTERN (CONCAT "LETTMP#" - (STRINGIMAGE |$letGenVarCounter|)))) - (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) - (SETQ |l2| (|bfLET2| |patrev| |g|)) - (COND - ((AND (CONSP |l2|) (ATOM (CAR |l2|))) - (SETQ |l2| (CONS |l2| NIL)))) - (COND - ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|)) - ((PROGN - (SETQ |ISTMP#1| (|last| |l2|)) - (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T) - (PROGN - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQUAL (CAR |ISTMP#2|) |var1|) - (PROGN - (SETQ |ISTMP#3| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CDR |ISTMP#3|) NIL) - (PROGN - (SETQ |val1| (CAR |ISTMP#3|)) - #0#))))))) - (CONS (LIST 'L%T |g| |rev|) - (APPEND (REVERSE (CDR (REVERSE |l2|))) - (CONS (|bfLetForm| |var1| - (LIST 'NREVERSE |val1|)) - NIL)))) - (#1# - (CONS (LIST 'L%T |g| |rev|) - (APPEND |l2| - (CONS (|bfLetForm| |var1| - (LIST 'NREVERSE |var1|)) - NIL))))))) + (SETQ |patrev| (|bfISReverse| |var2| |var1|)) + (SETQ |rev| (LIST 'REVERSE |rhs|)) + (SETQ |g| + (INTERN (CONCAT "LETTMP#" + (STRINGIMAGE |$letGenVarCounter|)))) + (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) + (SETQ |l2| (|bfLET2| |patrev| |g|)) + (COND + ((AND (CONSP |l2|) (ATOM (CAR |l2|))) + (SETQ |l2| (CONS |l2| NIL)))) + (COND + ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|)) + ((PROGN + (SETQ |ISTMP#1| (|last| |l2|)) + (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T) + (PROGN + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQUAL (CAR |ISTMP#2|) |var1|) + (PROGN + (SETQ |ISTMP#3| (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CDR |ISTMP#3|) NIL) + (PROGN + (SETQ |val1| (CAR |ISTMP#3|)) + #0#))))))) + (CONS (LIST 'L%T |g| |rev|) + (APPEND (REVERSE (CDR (REVERSE |l2|))) + (CONS (|bfLetForm| |var1| + (LIST 'NREVERSE |val1|)) + NIL)))) + (#1# + (CONS (LIST 'L%T |g| |rev|) + (APPEND |l2| + (CONS (|bfLetForm| |var1| + (LIST 'NREVERSE |var1|)) + NIL)))))) ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL) (PROGN (SETQ |ISTMP#1| (CDR |lhs|)) @@ -895,12 +865,11 @@ (PROGN (SETQ |var1| (CAR |ISTMP#1|)) #0#)))) (LIST 'COND (LIST (LIST 'EQUAL |var1| |rhs|) |var1|))) (#1# - (PROGN - (SETQ |isPred| - (COND - (|$inDefIS| (|bfIS1| |rhs| |lhs|)) - (#1# (|bfIS| |rhs| |lhs|)))) - (LIST 'COND (LIST |isPred| |rhs|)))))))) + (SETQ |isPred| + (COND + (|$inDefIS| (|bfIS1| |rhs| |lhs|)) + (#1# (|bfIS| |rhs| |lhs|)))) + (LIST 'COND (LIST |isPred| |rhs|))))))) (DEFUN |bfLET| (|lhs| |rhs|) (PROG (|$letGenVarCounter|) @@ -916,25 +885,22 @@ ((AND (EQ |acc| 'CAR) (EQCAR |expr| 'REVERSE)) (LIST 'CAR (CONS 'LAST (CDR |expr|)))) (#0='T - (PROGN - (SETQ |funs| - '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR)) - (SETQ |p| (|bfPosition| (CAR |expr|) |funs|)) - (COND - ((EQUAL |p| (- 1)) (LIST |acc| |expr|)) - (#0# - (PROGN - (SETQ |funsA| - '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR - CAAADR CAADDR CADAAR CADDAR CADADR CADDDR)) - (SETQ |funsR| - '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR - CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR)) - (COND - ((EQ |acc| 'CAR) - (CONS (ELT |funsA| |p|) (CDR |expr|))) - ('T (CONS (ELT |funsR| |p|) (CDR |expr|))))))))))))) + (SETQ |funs| + '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR + CDAAR CDDAR CDADR CDDDR)) + (SETQ |p| (|bfPosition| (CAR |expr|) |funs|)) + (COND + ((EQUAL |p| (- 1)) (LIST |acc| |expr|)) + (#0# + (SETQ |funsA| + '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR + CAAADR CAADDR CADAAR CADDAR CADADR CADDDR)) + (SETQ |funsR| + '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR + CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR)) + (COND + ((EQ |acc| 'CAR) (CONS (ELT |funsA| |p|) (CDR |expr|))) + ('T (CONS (ELT |funsR| |p|) (CDR |expr|))))))))))) (DEFUN |bfPosition| (|x| |l|) (|bfPosn| |x| |l| 0)) @@ -966,15 +932,9 @@ ((AND (CONSP |x|) (EQ (CAR |x|) 'CONS)) (COND ((NULL (CADDR |x|)) (LIST 'CONS (CADR |x|) |a|)) - (#0='T - (PROGN - (SETQ |y| (|bfISReverse| (CADDR |x|) NIL)) - (RPLACA (CDDR |y|) (LIST 'CONS (CADR |x|) |a|)) - |y|)))) - (#0# - (PROGN - (|bpSpecificErrorHere| "Error in bfISReverse") - (|bpTrap|))))))) + (#0='T (SETQ |y| (|bfISReverse| (CADDR |x|) NIL)) + (RPLACA (CDDR |y|) (LIST 'CONS (CADR |x|) |a|)) |y|))) + (#0# (|bpSpecificErrorHere| "Error in bfISReverse") (|bpTrap|)))))) (DEFUN |bfIS1| (|lhs| |rhs|) (PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |b| |g| |l| |d| |ISTMP#2| @@ -1003,10 +963,9 @@ (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) (PROGN (SETQ |d| (CAR |ISTMP#2|)) #0#)))))) - (PROGN - (SETQ |l| (|bfLET| |c| |lhs|)) - (|bfAND| (LIST (|bfIS1| |lhs| |d|) - (|bfMKPROGN| (LIST |l| ''T)))))) + (SETQ |l| (|bfLET| |c| |lhs|)) + (|bfAND| (LIST (|bfIS1| |lhs| |d|) + (|bfMKPROGN| (LIST |l| ''T))))) ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'EQUAL) (PROGN (SETQ |ISTMP#1| (CDR |rhs|)) @@ -1014,13 +973,11 @@ (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0#)))) (LIST 'EQUAL |lhs| |a|)) ((CONSP |lhs|) - (PROGN - (SETQ |g| - (INTERN (CONCAT "ISTMP#" - (STRINGIMAGE |$isGenVarCounter|)))) - (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) - (|bfMKPROGN| - (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|))))) + (SETQ |g| + (INTERN (CONCAT "ISTMP#" + (STRINGIMAGE |$isGenVarCounter|)))) + (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) + (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|)))) ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'CONS) (PROGN (SETQ |ISTMP#1| (CDR |rhs|)) @@ -1046,26 +1003,24 @@ ((EQ |b| 'DOT) (|bfAND| (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CAR |lhs|) |a|)))) - (#1# - (PROGN - (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|)) - (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|)) - (COND - ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN) - (PROGN - (SETQ |ISTMP#1| (CDR |a1|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |c| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (EQUAL (CAR |ISTMP#2|) ''T))))) - (CONSP |b1|) (EQ (CAR |b1|) 'PROGN) - (PROGN (SETQ |cls| (CDR |b1|)) #0#)) - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (|bfMKPROGN| (CONS |c| |cls|))))) - (#1# (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|)))))))) + (#1# (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|)) + (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|)) + (COND + ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN) + (PROGN + (SETQ |ISTMP#1| (CDR |a1|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |c| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (EQUAL (CAR |ISTMP#2|) ''T))))) + (CONSP |b1|) (EQ (CAR |b1|) 'PROGN) + (PROGN (SETQ |cls| (CDR |b1|)) #0#)) + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (|bfMKPROGN| (CONS |c| |cls|))))) + (#1# (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|))))))) ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'APPEND) (PROGN (SETQ |ISTMP#1| (CDR |rhs|)) @@ -1075,37 +1030,34 @@ (SETQ |ISTMP#2| (CDR |ISTMP#1|)) (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0#)))))) - (PROGN - (SETQ |patrev| (|bfISReverse| |b| |a|)) - (SETQ |g| - (INTERN (CONCAT "ISTMP#" - (STRINGIMAGE |$isGenVarCounter|)))) - (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) - (SETQ |rev| - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (LIST 'PROGN - (LIST 'L%T |g| - (LIST 'REVERSE |lhs|)) - ''T)))) - (SETQ |l2| (|bfIS1| |g| |patrev|)) - (COND - ((AND (CONSP |l2|) (ATOM (CAR |l2|))) - (SETQ |l2| (CONS |l2| NIL)))) - (COND - ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|))) - (#1# - (|bfAND| (CONS |rev| - (APPEND |l2| - (CONS - (LIST 'PROGN - (|bfLetForm| |a| - (LIST 'NREVERSE |a|)) - ''T) - NIL)))))))) - (#1# - (PROGN - (|bpSpecificErrorHere| "bad IS code is generated") - (|bpTrap|))))))) + (SETQ |patrev| (|bfISReverse| |b| |a|)) + (SETQ |g| + (INTERN (CONCAT "ISTMP#" + (STRINGIMAGE |$isGenVarCounter|)))) + (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) + (SETQ |rev| + (|bfAND| (LIST (LIST 'CONSP |lhs|) + (LIST 'PROGN + (LIST 'L%T |g| + (LIST 'REVERSE |lhs|)) + ''T)))) + (SETQ |l2| (|bfIS1| |g| |patrev|)) + (COND + ((AND (CONSP |l2|) (ATOM (CAR |l2|))) + (SETQ |l2| (CONS |l2| NIL)))) + (COND + ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|))) + (#1# + (|bfAND| (CONS |rev| + (APPEND |l2| + (CONS + (LIST 'PROGN + (|bfLetForm| |a| + (LIST 'NREVERSE |a|)) + ''T) + NIL))))))) + (#1# (|bpSpecificErrorHere| "bad IS code is generated") + (|bpTrap|)))))) (DEFUN |bfApplication| (|bfop| |bfarg|) (COND @@ -1328,14 +1280,12 @@ (RETURN (COND (|$bfClamming| - (PROGN - (SETQ |LETTMP#1| - (|shoeComp| - (CAR (|bfDef1| (LIST |op| |args| |body|))))) - (SETQ |op1| (CADR . #0=(|LETTMP#1|))) - (SETQ |arg1| (CADDR . #0#)) - (SETQ |body1| (CDDDR . #0#)) - (|bfCompHash| |op1| |arg1| |body1|))) + (SETQ |LETTMP#1| + (|shoeComp| + (CAR (|bfDef1| (LIST |op| |args| |body|))))) + (SETQ |op1| (CADR . #0=(|LETTMP#1|))) + (SETQ |arg1| (CADDR . #0#)) (SETQ |body1| (CDDDR . #0#)) + (|bfCompHash| |op1| |arg1| |body1|)) ('T (|bfTuple| (LET ((|bfVar#101| NIL) @@ -1439,21 +1389,19 @@ (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) (PROGN (SETQ |b| (CAR |ISTMP#1|)) #0#)))) (LIST T 'QUOTE |b| |body|)) - (#1='T - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (COND - ((ATOM |y|) (LIST NIL NIL |g| |body|)) - (#1# - (CASE (CAR |y|) - (|%DefaultValue| - (LET ((|p| (CADR |y|)) (|v| (CADDR |y|))) - (LIST NIL NIL (LIST '&OPTIONAL (LIST |p| |v|)) - |body|))) - (T (LIST NIL NIL |g| - (|bfMKPROGN| - (LIST (|bfLET| (|compFluidize| |y|) |g|) - |body|))))))))))))) + (#1='T (SETQ |g| (|bfGenSymbol|)) + (COND + ((ATOM |y|) (LIST NIL NIL |g| |body|)) + (#1# + (CASE (CAR |y|) + (|%DefaultValue| + (LET ((|p| (CADR |y|)) (|v| (CADDR |y|))) + (LIST NIL NIL (LIST '&OPTIONAL (LIST |p| |v|)) + |body|))) + (T (LIST NIL NIL |g| + (|bfMKPROGN| + (LIST (|bfLET| (|compFluidize| |y|) |g|) + |body|)))))))))))) (DEFUN |shoeCompTran| (|x|) (PROG (|$dollarVars| |$locVars| |$fluidVars| |fvs| |fl| |fvars| @@ -1503,41 +1451,36 @@ (RETURN (COND ((ATOM |body|) NIL) - (#0='T - (PROGN - (SETQ |op| (CAR |body|)) - (SETQ |args| (CDR |body|)) - (COND - ((MEMBER |op| '(RETURN RETURN-FROM)) T) - ((MEMBER |op| '(LET PROG LOOP BLOCK DECLARE LAMBDA)) NIL) - ((LET ((|bfVar#105| NIL) (|bfVar#104| |body|) (|t| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#104|) - (PROGN (SETQ |t| (CAR |bfVar#104|)) NIL)) - (RETURN |bfVar#105|)) - ('T - (PROGN - (SETQ |bfVar#105| (|needsPROG| |t|)) - (COND (|bfVar#105| (RETURN |bfVar#105|)))))) - (SETQ |bfVar#104| (CDR |bfVar#104|)))) - T) - (#0# NIL)))))))) + (#0='T (SETQ |op| (CAR |body|)) (SETQ |args| (CDR |body|)) + (COND + ((MEMBER |op| '(RETURN RETURN-FROM)) T) + ((MEMBER |op| '(LET PROG LOOP BLOCK DECLARE LAMBDA)) NIL) + ((LET ((|bfVar#105| NIL) (|bfVar#104| |body|) (|t| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#104|) + (PROGN (SETQ |t| (CAR |bfVar#104|)) NIL)) + (RETURN |bfVar#105|)) + ('T + (PROGN + (SETQ |bfVar#105| (|needsPROG| |t|)) + (COND (|bfVar#105| (RETURN |bfVar#105|)))))) + (SETQ |bfVar#104| (CDR |bfVar#104|)))) + T) + (#0# NIL))))))) (DEFUN |shoePROG| (|v| |b|) (PROG (|blist| |blast| |LETTMP#1|) (RETURN (COND ((NULL |b|) (LIST (LIST 'PROG |v|))) - ('T - (PROGN - (SETQ |LETTMP#1| (REVERSE |b|)) - (SETQ |blast| (CAR |LETTMP#1|)) - (SETQ |blist| (NREVERSE (CDR |LETTMP#1|))) - (LIST (CONS 'PROG - (CONS |v| - (APPEND |blist| - (CONS (LIST 'RETURN |blast|) NIL))))))))))) + ('T (SETQ |LETTMP#1| (REVERSE |b|)) + (SETQ |blast| (CAR |LETTMP#1|)) + (SETQ |blist| (NREVERSE (CDR |LETTMP#1|))) + (LIST (CONS 'PROG + (CONS |v| + (APPEND |blist| + (CONS (LIST 'RETURN |blast|) NIL)))))))))) (DEFUN |shoeFluids| (|x|) (COND @@ -1581,83 +1524,70 @@ ((MEMQ |x| |$dollarVars|) |$dollarVars|) (#0='T (CONS |x| |$dollarVars|))))) (#0# NIL))) - (#0# - (PROGN - (SETQ U (CAR |x|)) - (COND - ((EQ U 'QUOTE) NIL) - ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |l| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T)))))) - (PROGN - (RPLACA |x| 'SETQ) - (|shoeCompTran1| |r|) + (#0# (SETQ U (CAR |x|)) + (COND + ((EQ U 'QUOTE) NIL) + ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |l| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (EQ (CDR |ISTMP#2|) NIL) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T)))))) + (RPLACA |x| 'SETQ) (|shoeCompTran1| |r|) + (COND + ((IDENTP |l|) + (COND + ((NOT (|bfBeginsDollar| |l|)) + (SETQ |$locVars| + (COND + ((MEMQ |l| |$locVars|) |$locVars|) + (#0# (CONS |l| |$locVars|))))) + (#0# + (SETQ |$dollarVars| + (COND + ((MEMQ |l| |$dollarVars|) |$dollarVars|) + (#0# (CONS |l| |$dollarVars|))))))) + ((EQCAR |l| 'FLUID) + (SETQ |$fluidVars| + (COND + ((MEMQ (CADR |l|) |$fluidVars|) |$fluidVars|) + (#0# (CONS (CADR |l|) |$fluidVars|)))) + (RPLACA (CDR |x|) (CADR |l|))))) + ((MEMQ U '(PROG LAMBDA)) (SETQ |newbindings| NIL) + (LET ((|bfVar#106| (CADR |x|)) (|y| NIL)) + (LOOP (COND - ((IDENTP |l|) + ((OR (ATOM |bfVar#106|) + (PROGN (SETQ |y| (CAR |bfVar#106|)) NIL)) + (RETURN NIL)) + (#1='T (COND - ((NOT (|bfBeginsDollar| |l|)) - (SETQ |$locVars| - (COND - ((MEMQ |l| |$locVars|) |$locVars|) - (#0# (CONS |l| |$locVars|))))) - (#0# - (SETQ |$dollarVars| - (COND - ((MEMQ |l| |$dollarVars|) |$dollarVars|) - (#0# (CONS |l| |$dollarVars|))))))) - ((EQCAR |l| 'FLUID) - (PROGN - (SETQ |$fluidVars| - (COND - ((MEMQ (CADR |l|) |$fluidVars|) - |$fluidVars|) - (#0# (CONS (CADR |l|) |$fluidVars|)))) - (RPLACA (CDR |x|) (CADR |l|))))))) - ((MEMQ U '(PROG LAMBDA)) - (PROGN - (SETQ |newbindings| NIL) - (LET ((|bfVar#106| (CADR |x|)) (|y| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#106|) - (PROGN (SETQ |y| (CAR |bfVar#106|)) NIL)) - (RETURN NIL)) - (#1='T - (COND - ((NOT (MEMQ |y| |$locVars|)) - (IDENTITY - (PROGN - (SETQ |$locVars| (CONS |y| |$locVars|)) - (SETQ |newbindings| - (CONS |y| |newbindings|)))))))) - (SETQ |bfVar#106| (CDR |bfVar#106|)))) - (SETQ |res| (|shoeCompTran1| (CDDR |x|))) - (SETQ |$locVars| - (LET ((|bfVar#108| NIL) (|bfVar#107| |$locVars|) - (|y| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#107|) - (PROGN - (SETQ |y| (CAR |bfVar#107|)) - NIL)) - (RETURN (NREVERSE |bfVar#108|))) - (#1# - (AND (NOT (MEMQ |y| |newbindings|)) - (SETQ |bfVar#108| - (CONS |y| |bfVar#108|))))) - (SETQ |bfVar#107| (CDR |bfVar#107|))))))) - (#0# - (PROGN - (|shoeCompTran1| (CAR |x|)) - (|shoeCompTran1| (CDR |x|))))))))))) + ((NOT (MEMQ |y| |$locVars|)) + (IDENTITY + (PROGN + (SETQ |$locVars| (CONS |y| |$locVars|)) + (SETQ |newbindings| + (CONS |y| |newbindings|)))))))) + (SETQ |bfVar#106| (CDR |bfVar#106|)))) + (SETQ |res| (|shoeCompTran1| (CDDR |x|))) + (SETQ |$locVars| + (LET ((|bfVar#108| NIL) (|bfVar#107| |$locVars|) + (|y| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#107|) + (PROGN (SETQ |y| (CAR |bfVar#107|)) NIL)) + (RETURN (NREVERSE |bfVar#108|))) + (#1# + (AND (NOT (MEMQ |y| |newbindings|)) + (SETQ |bfVar#108| (CONS |y| |bfVar#108|))))) + (SETQ |bfVar#107| (CDR |bfVar#107|)))))) + (#0# (|shoeCompTran1| (CAR |x|)) + (|shoeCompTran1| (CDR |x|))))))))) (DEFUN |bfTagged| (|a| |b|) (DECLARE (SPECIAL |$typings| |$op|)) @@ -1668,10 +1598,8 @@ ((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL)) ((EQ |b| '|fluid|) (|bfLET| (|compFluid| |a|) NIL)) ((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL)) - (#0='T - (PROGN - (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) - |a|)))) + (#0='T (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) + |a|))) (#0# (LIST 'THE |b| |a|)))) (DEFUN |bfAssign| (|l| |r|) @@ -1725,12 +1653,11 @@ ((EQCAR |c| 'COND) (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|)))) ('T - (PROGN - (SETQ |c1| - (COND - ((EQCAR |c| 'PROGN) (CDR |c|)) - (#0# (LIST |c|)))) - (LIST 'COND (CONS |a| |b1|) (CONS ''T |c1|))))))))) + (SETQ |c1| + (COND + ((EQCAR |c| 'PROGN) (CDR |c|)) + (#0# (LIST |c|)))) + (LIST 'COND (CONS |a| |b1|) (CONS ''T |c1|)))))))) (DEFUN |bfExit| (|a| |b|) (LIST 'COND (LIST |a| (LIST 'IDENTITY |b|)))) @@ -1759,27 +1686,34 @@ (RETURN (COND ((NULL |x|) NIL) - (#0='T - (PROGN - (SETQ |f| (CAR |x|)) - (COND - ((ATOM |f|) (COND ((CDR |x|) NIL) ('T (LIST |f|)))) - ((EQCAR |f| 'PROGN) - (COND - ((CDR |x|) - (LET ((|bfVar#111| NIL) (|bfVar#110| (CDR |f|)) - (|i| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#110|) - (PROGN (SETQ |i| (CAR |bfVar#110|)) NIL)) - (RETURN (NREVERSE |bfVar#111|))) - ('T - (AND (NOT (ATOM |i|)) - (SETQ |bfVar#111| (CONS |i| |bfVar#111|))))) - (SETQ |bfVar#110| (CDR |bfVar#110|))))) - (#0# (CDR |f|)))) - (#0# (LIST |f|))))))))) + (#0='T (SETQ |f| (CAR |x|)) + (COND + ((ATOM |f|) (COND ((CDR |x|) NIL) ('T (LIST |f|)))) + ((EQCAR |f| 'PROGN) + (COND + ((CDR |x|) + (LET ((|bfVar#111| NIL) (|bfVar#110| (CDR |f|)) + (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#110|) + (PROGN (SETQ |i| (CAR |bfVar#110|)) NIL)) + (RETURN (NREVERSE |bfVar#111|))) + ('T + (AND (NOT (ATOM |i|)) + (SETQ |bfVar#111| (CONS |i| |bfVar#111|))))) + (SETQ |bfVar#110| (CDR |bfVar#110|))))) + (#0# (CDR |f|)))) + (#0# (LIST |f|)))))))) + +(DEFUN |bfWashCONDBranchBody| (|x|) + (PROG (|y|) + (RETURN + (COND + ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN) + (PROGN (SETQ |y| (CDR |x|)) 'T)) + |y|) + ('T (LIST |x|)))))) (DEFUN |bfSequence| (|l|) (PROG (|f| |aft| |before| |no| |transform| |b| |ISTMP#5| |ISTMP#4| @@ -1788,72 +1722,73 @@ (COND ((NULL |l|) NIL) (#0='T - (PROGN - (SETQ |transform| - (LET ((|bfVar#113| NIL) (|bfVar#112| |l|) (|x| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#112|) - (PROGN (SETQ |x| (CAR |bfVar#112|)) NIL) - (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (EQ (CDR |ISTMP#1|) NIL) - (PROGN - (SETQ |ISTMP#2| - (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |a| - (CAR |ISTMP#2|)) - (SETQ |ISTMP#3| - (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CDR |ISTMP#3|) NIL) - (PROGN - (SETQ |ISTMP#4| - (CAR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (EQ (CAR |ISTMP#4|) - 'IDENTITY) - (PROGN - (SETQ |ISTMP#5| - (CDR |ISTMP#4|)) - (AND - (CONSP |ISTMP#5|) - (EQ - (CDR |ISTMP#5|) - NIL) - (PROGN - (SETQ |b| - (CAR |ISTMP#5|)) - 'T)))))))))))))) - (RETURN (NREVERSE |bfVar#113|))) - ('T - (SETQ |bfVar#113| - (CONS (LIST |a| |b|) |bfVar#113|)))) - (SETQ |bfVar#112| (CDR |bfVar#112|))))) - (SETQ |no| (LENGTH |transform|)) - (SETQ |before| (|bfTake| |no| |l|)) - (SETQ |aft| (|bfDrop| |no| |l|)) - (COND - ((NULL |before|) - (COND - ((NULL (CDR |l|)) - (PROGN - (SETQ |f| (CAR |l|)) + (SETQ |transform| + (LET ((|bfVar#113| NIL) (|bfVar#112| |l|) (|x| NIL)) + (LOOP (COND - ((EQCAR |f| 'PROGN) (|bfSequence| (CDR |f|))) - ('T |f|)))) - (#0# - (|bfMKPROGN| - (LIST (CAR |l|) (|bfSequence| (CDR |l|))))))) - ((NULL |aft|) (CONS 'COND |transform|)) - (#0# - (CONS 'COND - (APPEND |transform| - (CONS (LIST ''T (|bfSequence| |aft|)) NIL))))))))))) + ((OR (ATOM |bfVar#112|) + (PROGN (SETQ |x| (CAR |bfVar#112|)) NIL) + (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND) + (PROGN + (SETQ |ISTMP#1| (CDR |x|)) + (AND (CONSP |ISTMP#1|) + (EQ (CDR |ISTMP#1|) NIL) + (PROGN + (SETQ |ISTMP#2| + (CAR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |a| (CAR |ISTMP#2|)) + (SETQ |ISTMP#3| + (CDR |ISTMP#2|)) + (AND (CONSP |ISTMP#3|) + (EQ (CDR |ISTMP#3|) NIL) + (PROGN + (SETQ |ISTMP#4| + (CAR |ISTMP#3|)) + (AND (CONSP |ISTMP#4|) + (EQ (CAR |ISTMP#4|) + 'IDENTITY) + (PROGN + (SETQ |ISTMP#5| + (CDR |ISTMP#4|)) + (AND + (CONSP |ISTMP#5|) + (EQ (CDR |ISTMP#5|) + NIL) + (PROGN + (SETQ |b| + (CAR |ISTMP#5|)) + #1='T)))))))))))))) + (RETURN (NREVERSE |bfVar#113|))) + ('T + (SETQ |bfVar#113| + (CONS (CONS |a| + (|bfWashCONDBranchBody| |b|)) + |bfVar#113|)))) + (SETQ |bfVar#112| (CDR |bfVar#112|))))) + (SETQ |no| (LENGTH |transform|)) + (SETQ |before| (|bfTake| |no| |l|)) + (SETQ |aft| (|bfDrop| |no| |l|)) + (COND + ((NULL |before|) + (COND + ((AND (CONSP |l|) (EQ (CDR |l|) NIL) + (PROGN (SETQ |f| (CAR |l|)) #1#)) + (COND + ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN)) + (|bfSequence| (CDR |f|))) + (#0# |f|))) + (#0# + (|bfMKPROGN| (LIST (CAR |l|) (|bfSequence| (CDR |l|))))))) + ((NULL |aft|) (CONS 'COND |transform|)) + (#0# + (CONS 'COND + (APPEND |transform| + (CONS (CONS ''T + (|bfWashCONDBranchBody| + (|bfSequence| |aft|))) + NIL)))))))))) (DEFUN |bfWhere| (|context| |expr|) (PROG (|a| |nondefs| |defs| |opassoc| |LETTMP#1|) @@ -2133,19 +2068,17 @@ (COND ((SETQ |t'| (CDR (ASSOC (|coreSymbol| |t|) |$NativeTypeTable|))) - (PROGN - (SETQ |t'| - (COND - ((|%hasFeature| :SBCL) - (|bfColonColon| 'SB-ALIEN |t'|)) - ((|%hasFeature| :CLISP) - (|bfColonColon| 'FFI |t'|)) - (#0='T |t'|))) - (COND - ((AND (EQ |t| '|string|) (|%hasFeature| :SBCL)) - (LIST |t'| :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE - 'BASE-CHAR)) - (#0# |t'|)))) + (SETQ |t'| + (COND + ((|%hasFeature| :SBCL) + (|bfColonColon| 'SB-ALIEN |t'|)) + ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI |t'|)) + (#0='T |t'|))) + (COND + ((AND (EQ |t| '|string|) (|%hasFeature| :SBCL)) + (LIST |t'| :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE + 'BASE-CHAR)) + (#0# |t'|))) ((MEMBER |t| '(|byte| |uint8|)) (COND ((|%hasFeature| :SBCL) @@ -2236,21 +2169,17 @@ ((EQ |t| '|string|) (|nativeType| |t|)) ((OR (ATOM |t|) (NOT (EQL (LENGTH |t|) 2))) (|coreError| "invalid argument type for a native function")) - (#0='T - (PROGN - (SETQ |m| (CAR |t|)) - (SETQ |c| (CAADR . #1=(|t|))) - (SETQ |t'| (CADADR . #1#)) - (COND - ((NOT (MEMBER |m| '(|readonly| |writeonly| |readwrite|))) - (|coreError| - "missing modifier for argument type for a native function")) - ((NOT (MEMBER |c| '(|buffer| |pointer|))) - (|coreError| - "expect 'buffer' or 'pointer' type instance")) - ((NOT (MEMBER |t'| |$NativeSimpleDataTypes|)) - (|coreError| "expected simple native data type")) - (#0# (|nativeType| (CADR |t|)))))))))) + (#0='T (SETQ |m| (CAR |t|)) (SETQ |c| (CAADR . #1=(|t|))) + (SETQ |t'| (CADADR . #1#)) + (COND + ((NOT (MEMBER |m| '(|readonly| |writeonly| |readwrite|))) + (|coreError| + "missing modifier for argument type for a native function")) + ((NOT (MEMBER |c| '(|buffer| |pointer|))) + (|coreError| "expect 'buffer' or 'pointer' type instance")) + ((NOT (MEMBER |t'| |$NativeSimpleDataTypes|)) + (|coreError| "expected simple native data type")) + (#0# (|nativeType| (CADR |t|))))))))) (DEFUN |needsStableReference?| (|t|) (PROG (|m|) @@ -2268,19 +2197,17 @@ ((|%hasFeature| :SBCL) (COND ((NOT (|needsStableReference?| |t|)) |a|) - (#0='T - (PROGN - (SETQ |c| (CAADR . #1=(|t|))) - (SETQ |y| (CADADR . #1#)) - (COND - ((EQ |c| '|buffer|) - (LIST (|bfColonColon| 'SB-SYS 'VECTOR-SAP) |a|)) - ((EQ |c| '|pointer|) - (LIST (|bfColonColon| 'SB-SYS 'ALIEN-SAP) |a|)) - ((|needsStableReference?| |t|) - (|fatalError| - (CONCAT "don't know how to coerce argument for native type" - (SYMBOL-NAME |c|))))))))) + (#0='T (SETQ |c| (CAADR . #1=(|t|))) + (SETQ |y| (CADADR . #1#)) + (COND + ((EQ |c| '|buffer|) + (LIST (|bfColonColon| 'SB-SYS 'VECTOR-SAP) |a|)) + ((EQ |c| '|pointer|) + (LIST (|bfColonColon| 'SB-SYS 'ALIEN-SAP) |a|)) + ((|needsStableReference?| |t|) + (|fatalError| + (CONCAT "don't know how to coerce argument for native type" + (SYMBOL-NAME |c|)))))))) (#0# (|fatalError| "don't know how to coerce argument for native type")))))) @@ -2317,91 +2244,91 @@ (SETQ |bfVar#128| (CDR |bfVar#128|)))) (LIST (LIST 'DEFENTRY |op| |argtypes| (LIST |rettype| (SYMBOL-NAME |op'|))))) - (#1='T - (PROGN - (SETQ |cop| (CONCAT (SYMBOL-NAME |op'|) "_stub")) - (SETQ |cargs| - (LET ((|bfVar#136| NIL) - (|bfVar#135| (- (LENGTH |s|) 1)) (|i| 0)) - (LOOP - (COND - ((> |i| |bfVar#135|) - (RETURN (NREVERSE |bfVar#136|))) - (#0# - (SETQ |bfVar#136| - (CONS (|genGCLnativeTranslation,mkCArgName| - |i|) - |bfVar#136|)))) - (SETQ |i| (+ |i| 1))))) - (SETQ |ccode| - (LET ((|bfVar#132| "") - (|bfVar#134| - (CONS (|genGCLnativeTranslation,gclTypeInC| - |t|) - (CONS " " - (CONS |cop| - (CONS "(" - (APPEND - (LET - ((|bfVar#130| NIL) (|x| |s|) - (|a| |cargs|)) - (LOOP - (COND - ((OR (ATOM |x|) - (ATOM |a|)) - (RETURN - (NREVERSE |bfVar#130|))) - (#0# - (SETQ |bfVar#130| - (CONS - (|genGCLnativeTranslation,cparm| - |x| |a|) - |bfVar#130|)))) - (SETQ |x| (CDR |x|)) - (SETQ |a| (CDR |a|)))) - (CONS ") { " - (CONS - (COND - ((NOT (EQ |t| '|void|)) - "return ") - (#1# '||)) - (CONS (SYMBOL-NAME |op'|) - (CONS "(" - (APPEND - (LET - ((|bfVar#131| NIL) - (|x| |s|) (|a| |cargs|)) - (LOOP - (COND - ((OR (ATOM |x|) - (ATOM |a|)) - (RETURN - (NREVERSE - |bfVar#131|))) - (#0# - (SETQ |bfVar#131| - (CONS - (|genGCLnativeTranslation,gclArgsInC| - |x| |a|) - |bfVar#131|)))) - (SETQ |x| (CDR |x|)) - (SETQ |a| (CDR |a|)))) - (CONS "); }" NIL)))))))))))) - (|bfVar#133| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#134|) - (PROGN - (SETQ |bfVar#133| (CAR |bfVar#134|)) - NIL)) - (RETURN |bfVar#132|)) - (#0# - (SETQ |bfVar#132| - (CONCAT |bfVar#132| |bfVar#133|)))) - (SETQ |bfVar#134| (CDR |bfVar#134|))))) - (LIST (LIST 'CLINES |ccode|) - (LIST 'DEFENTRY |op| |argtypes| - (LIST |rettype| |cop|)))))))))) + (#1='T (SETQ |cop| (CONCAT (SYMBOL-NAME |op'|) "_stub")) + (SETQ |cargs| + (LET ((|bfVar#136| NIL) + (|bfVar#135| (- (LENGTH |s|) 1)) (|i| 0)) + (LOOP + (COND + ((> |i| |bfVar#135|) + (RETURN (NREVERSE |bfVar#136|))) + (#0# + (SETQ |bfVar#136| + (CONS (|genGCLnativeTranslation,mkCArgName| + |i|) + |bfVar#136|)))) + (SETQ |i| (+ |i| 1))))) + (SETQ |ccode| + (LET ((|bfVar#132| "") + (|bfVar#134| + (CONS (|genGCLnativeTranslation,gclTypeInC| + |t|) + (CONS " " + (CONS |cop| + (CONS "(" + (APPEND + (LET + ((|bfVar#130| NIL) (|x| |s|) + (|a| |cargs|)) + (LOOP + (COND + ((OR (ATOM |x|) + (ATOM |a|)) + (RETURN + (NREVERSE + |bfVar#130|))) + (#0# + (SETQ |bfVar#130| + (CONS + (|genGCLnativeTranslation,cparm| + |x| |a|) + |bfVar#130|)))) + (SETQ |x| (CDR |x|)) + (SETQ |a| (CDR |a|)))) + (CONS ") { " + (CONS + (COND + ((NOT (EQ |t| '|void|)) + "return ") + (#1# '||)) + (CONS (SYMBOL-NAME |op'|) + (CONS "(" + (APPEND + (LET + ((|bfVar#131| NIL) + (|x| |s|) + (|a| |cargs|)) + (LOOP + (COND + ((OR (ATOM |x|) + (ATOM |a|)) + (RETURN + (NREVERSE + |bfVar#131|))) + (#0# + (SETQ |bfVar#131| + (CONS + (|genGCLnativeTranslation,gclArgsInC| + |x| |a|) + |bfVar#131|)))) + (SETQ |x| (CDR |x|)) + (SETQ |a| (CDR |a|)))) + (CONS "); }" NIL)))))))))))) + (|bfVar#133| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#134|) + (PROGN + (SETQ |bfVar#133| (CAR |bfVar#134|)) + NIL)) + (RETURN |bfVar#132|)) + (#0# + (SETQ |bfVar#132| + (CONCAT |bfVar#132| |bfVar#133|)))) + (SETQ |bfVar#134| (CDR |bfVar#134|))))) + (LIST (LIST 'CLINES |ccode|) + (LIST 'DEFENTRY |op| |argtypes| + (LIST |rettype| |cop|))))))))) (DEFUN |genGCLnativeTranslation,mkCArgName| (|i|) (CONCAT "x" (STRINGIMAGE |i|))) @@ -2438,18 +2365,15 @@ (COND ((MEMBER |x| |$NativeSimpleDataTypes|) |a|) ((EQ |x| '|string|) |a|) - (#0='T - (PROGN - (SETQ |c| (CAADR |x|)) - (SETQ |y| (CADADR |x|)) - (COND - ((EQ |c| '|pointer|) |a|) - ((EQ |y| '|char|) (CONCAT |a| "->st.st_self")) - ((EQ |y| '|byte|) (CONCAT |a| "->ust.ust_self")) - ((EQ |y| '|int|) (CONCAT |a| "->fixa.fixa_self")) - ((EQ |y| '|float|) (CONCAT |a| "->sfa.sfa_self")) - ((EQ |y| '|double|) (CONCAT |a| "->lfa.lfa_self")) - (#0# (|coreError| "unknown argument type"))))))))) + (#0='T (SETQ |c| (CAADR |x|)) (SETQ |y| (CADADR |x|)) + (COND + ((EQ |c| '|pointer|) |a|) + ((EQ |y| '|char|) (CONCAT |a| "->st.st_self")) + ((EQ |y| '|byte|) (CONCAT |a| "->ust.ust_self")) + ((EQ |y| '|int|) (CONCAT |a| "->fixa.fixa_self")) + ((EQ |y| '|float|) (CONCAT |a| "->sfa.sfa_self")) + ((EQ |y| '|double|) (CONCAT |a| "->lfa.lfa_self")) + (#0# (|coreError| "unknown argument type")))))))) (DEFUN |genGCLnativeTranslation,gclArgsInC| (|x| |a|) (CONCAT (|genGCLnativeTranslation,gclArgInC| (CAR |x|) (CAR |a|)) @@ -2530,26 +2454,23 @@ (RETURN (COND ((|isSimpleNativeType| |x|) "") - (#0='T - (PROGN - (SETQ |c| (CAADR |x|)) - (SETQ |y| (CADADR |x|)) - (COND - ((EQ |c| '|buffer|) - (COND - ((OR (EQ |y| '|char|) (EQ |y| '|byte|)) - (COND - ((< |$ECLVersionNumber| 90100) "->vector.self.ch") - ((EQ |y| '|char|) "->vector.self.i8") - (#0# "->vector.self.b8"))) - ((EQ |y| '|int|) "->vector.self.fix") - ((EQ |y| '|float|) "->vector.self.sf") - ((EQ |y| '|double|) "->vector.self.df") - (#0# - (|coreError| - "unknown argument to buffer type constructor")))) - ((EQ |c| '|pointer|) '||) - (#0# (|coreError| "unknown type constructor"))))))))) + (#0='T (SETQ |c| (CAADR |x|)) (SETQ |y| (CADADR |x|)) + (COND + ((EQ |c| '|buffer|) + (COND + ((OR (EQ |y| '|char|) (EQ |y| '|byte|)) + (COND + ((< |$ECLVersionNumber| 90100) "->vector.self.ch") + ((EQ |y| '|char|) "->vector.self.i8") + (#0# "->vector.self.b8"))) + ((EQ |y| '|int|) "->vector.self.fix") + ((EQ |y| '|float|) "->vector.self.sf") + ((EQ |y| '|double|) "->vector.self.df") + (#0# + (|coreError| + "unknown argument to buffer type constructor")))) + ((EQ |c| '|pointer|) '||) + (#0# (|coreError| "unknown type constructor")))))))) (DEFUN |genCLISPnativeTranslation| (|op| |s| |t| |op'|) (PROG (|forwardingFun| |ISTMP#2| |p| |fixups| |q| |call| |localPairs| @@ -2636,123 +2557,117 @@ ((NULL |unstableArgs|) (LIST 'DEFUN |op| |parms| (CONS |n| |parms|))) (#1='T - (PROGN - (SETQ |localPairs| - (LET ((|bfVar#156| NIL) - (|bfVar#155| |unstableArgs|) - (|bfVar#154| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#155|) - (PROGN - (SETQ |bfVar#154| - (CAR |bfVar#155|)) - NIL)) - (RETURN (NREVERSE |bfVar#156|))) - (#0# - (AND (CONSP |bfVar#154|) + (SETQ |localPairs| + (LET ((|bfVar#156| NIL) + (|bfVar#155| |unstableArgs|) + (|bfVar#154| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#155|) + (PROGN + (SETQ |bfVar#154| + (CAR |bfVar#155|)) + NIL)) + (RETURN (NREVERSE |bfVar#156|))) + (#0# + (AND (CONSP |bfVar#154|) + (PROGN + (SETQ |a| (CAR |bfVar#154|)) + (SETQ |ISTMP#1| (CDR |bfVar#154|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |x| (CAR |ISTMP#1|)) + (SETQ |y| (CDR |ISTMP#1|)) + #2='T))) + (SETQ |bfVar#156| + (CONS + (CONS |a| + (CONS |x| + (CONS |y| (GENSYM "loc")))) + |bfVar#156|))))) + (SETQ |bfVar#155| (CDR |bfVar#155|))))) + (SETQ |call| + (CONS |n| + (LET ((|bfVar#158| NIL) + (|bfVar#157| |parms|) (|p| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#157|) (PROGN - (SETQ |a| (CAR |bfVar#154|)) - (SETQ |ISTMP#1| - (CDR |bfVar#154|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |x| (CAR |ISTMP#1|)) - (SETQ |y| (CDR |ISTMP#1|)) - #2='T))) - (SETQ |bfVar#156| - (CONS - (CONS |a| - (CONS |x| - (CONS |y| (GENSYM "loc")))) - |bfVar#156|))))) - (SETQ |bfVar#155| (CDR |bfVar#155|))))) - (SETQ |call| - (CONS |n| - (LET ((|bfVar#158| NIL) - (|bfVar#157| |parms|) (|p| NIL)) + (SETQ |p| (CAR |bfVar#157|)) + NIL)) + (RETURN (NREVERSE |bfVar#158|))) + (#0# + (SETQ |bfVar#158| + (CONS + (|genCLISPnativeTranslation,actualArg| + |p| |localPairs|) + |bfVar#158|)))) + (SETQ |bfVar#157| (CDR |bfVar#157|)))))) + (SETQ |call| + (PROGN + (SETQ |fixups| + (LET ((|bfVar#160| NIL) + (|bfVar#159| |localPairs|) + (|p| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#157|) + ((OR (ATOM |bfVar#159|) (PROGN - (SETQ |p| (CAR |bfVar#157|)) + (SETQ |p| (CAR |bfVar#159|)) NIL)) - (RETURN (NREVERSE |bfVar#158|))) + (RETURN (NREVERSE |bfVar#160|))) (#0# - (SETQ |bfVar#158| - (CONS - (|genCLISPnativeTranslation,actualArg| - |p| |localPairs|) - |bfVar#158|)))) - (SETQ |bfVar#157| (CDR |bfVar#157|)))))) - (SETQ |call| - (PROGN - (SETQ |fixups| - (LET ((|bfVar#160| NIL) - (|bfVar#159| |localPairs|) - (|p| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#159|) - (PROGN - (SETQ |p| (CAR |bfVar#159|)) - NIL)) - (RETURN - (NREVERSE |bfVar#160|))) - (#0# - (AND - (NOT - (NULL - (SETQ |q| - (|genCLISPnativeTranslation,copyBack| - |p|)))) - (SETQ |bfVar#160| - (CONS |q| |bfVar#160|))))) - (SETQ |bfVar#159| - (CDR |bfVar#159|))))) - (COND - ((NULL |fixups|) (LIST |call|)) - (#1# - (LIST (CONS 'PROG1 - (CONS |call| |fixups|))))))) - (LET ((|bfVar#162| |localPairs|) (|bfVar#161| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#162|) - (PROGN - (SETQ |bfVar#161| (CAR |bfVar#162|)) - NIL)) - (RETURN NIL)) - (#0# - (AND (CONSP |bfVar#161|) - (PROGN - (SETQ |p| (CAR |bfVar#161|)) - (SETQ |ISTMP#1| (CDR |bfVar#161|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |x| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| - (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |y| (CAR |ISTMP#2|)) - (SETQ |a| (CDR |ISTMP#2|)) - #2#))))) - (SETQ |call| - (LIST - (CONS - (|bfColonColon| 'FFI - 'WITH-FOREIGN-OBJECT) - (CONS - (LIST |a| - (LIST 'FUNCALL - (LIST 'INTERN "getCLISPType" - "BOOTTRAN") - |p|) - |p|) - |call|))))))) - (SETQ |bfVar#162| (CDR |bfVar#162|)))) - (CONS 'DEFUN (CONS |op| (CONS |parms| |call|))))))) + (AND + (NOT + (NULL + (SETQ |q| + (|genCLISPnativeTranslation,copyBack| + |p|)))) + (SETQ |bfVar#160| + (CONS |q| |bfVar#160|))))) + (SETQ |bfVar#159| (CDR |bfVar#159|))))) + (COND + ((NULL |fixups|) (LIST |call|)) + (#1# + (LIST (CONS 'PROG1 (CONS |call| |fixups|))))))) + (LET ((|bfVar#162| |localPairs|) (|bfVar#161| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#162|) + (PROGN + (SETQ |bfVar#161| (CAR |bfVar#162|)) + NIL)) + (RETURN NIL)) + (#0# + (AND (CONSP |bfVar#161|) + (PROGN + (SETQ |p| (CAR |bfVar#161|)) + (SETQ |ISTMP#1| (CDR |bfVar#161|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |x| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) + (PROGN + (SETQ |y| (CAR |ISTMP#2|)) + (SETQ |a| (CDR |ISTMP#2|)) + #2#))))) + (SETQ |call| + (LIST + (CONS + (|bfColonColon| 'FFI + 'WITH-FOREIGN-OBJECT) + (CONS + (LIST |a| + (LIST 'FUNCALL + (LIST 'INTERN "getCLISPType" + "BOOTTRAN") + |p|) + |p|) + |call|))))))) + (SETQ |bfVar#162| (CDR |bfVar#162|)))) + (CONS 'DEFUN (CONS |op| (CONS |parms| |call|)))))) (SETQ |$foreignsDefsForCLisp| (CONS |foreignDecl| |$foreignsDefsForCLisp|)) (LIST |forwardingFun|))))) @@ -2888,20 +2803,18 @@ #0#))))))) (|coreError| "invalid function type")) (#1='T - (PROGN - (COND - ((AND (NOT (NULL |s|)) (SYMBOLP |s|)) - (SETQ |s| (LIST |s|)))) - (COND - ((|%hasFeature| :GCL) - (|genGCLnativeTranslation| |op| |s| |t| |op'|)) - ((|%hasFeature| :SBCL) - (|genSBCLnativeTranslation| |op| |s| |t| |op'|)) - ((|%hasFeature| :CLISP) - (|genCLISPnativeTranslation| |op| |s| |t| |op'|)) - ((|%hasFeature| :ECL) - (|genECLnativeTranslation| |op| |s| |t| |op'|)) - (#1# - (|fatalError| - "import declaration not implemented for this Lisp"))))))))) + (COND + ((AND (NOT (NULL |s|)) (SYMBOLP |s|)) (SETQ |s| (LIST |s|)))) + (COND + ((|%hasFeature| :GCL) + (|genGCLnativeTranslation| |op| |s| |t| |op'|)) + ((|%hasFeature| :SBCL) + (|genSBCLnativeTranslation| |op| |s| |t| |op'|)) + ((|%hasFeature| :CLISP) + (|genCLISPnativeTranslation| |op| |s| |t| |op'|)) + ((|%hasFeature| :ECL) + (|genECLnativeTranslation| |op| |s| |t| |op'|)) + (#1# + (|fatalError| + "import declaration not implemented for this Lisp")))))))) diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp index 08964695..6146ddc7 100644 --- a/src/boot/strap/includer.clisp +++ b/src/boot/strap/includer.clisp @@ -93,24 +93,20 @@ (RETURN (COND ((|bStreamNull| |stream|) (LIST NIL (LIST '|nullstream|))) - ('T - (PROGN - (SETQ |a| (CAAR |stream|)) - (COND - ((AND (NOT (< (LENGTH |a|) 8)) - (EQUAL (SUBSTRING |a| 0 8) ")package")) - (|shoePackageStartsAt| (CONS (CAAR |stream|) |lines|) - |sz| |name| (CDR |stream|))) - ((< (LENGTH |a|) |sz|) - (|shoePackageStartsAt| |lines| |sz| |name| - (CDR |stream|))) - ((AND (EQUAL (SUBSTRING |a| 0 |sz|) |name|) - (< |sz| (LENGTH |a|)) - (NOT (|shoeIdChar| (ELT |a| |sz|)))) - (LIST |lines| |stream|)) - ('T - (|shoePackageStartsAt| |lines| |sz| |name| - (CDR |stream|)))))))))) + ('T (SETQ |a| (CAAR |stream|)) + (COND + ((AND (NOT (< (LENGTH |a|) 8)) + (EQUAL (SUBSTRING |a| 0 8) ")package")) + (|shoePackageStartsAt| (CONS (CAAR |stream|) |lines|) |sz| + |name| (CDR |stream|))) + ((< (LENGTH |a|) |sz|) + (|shoePackageStartsAt| |lines| |sz| |name| (CDR |stream|))) + ((AND (EQUAL (SUBSTRING |a| 0 |sz|) |name|) + (< |sz| (LENGTH |a|)) + (NOT (|shoeIdChar| (ELT |a| |sz|)))) + (LIST |lines| |stream|)) + ('T + (|shoePackageStartsAt| |lines| |sz| |name| (CDR |stream|))))))))) (DEFUN |shoeFindLines| (|fn| |name| |a|) (PROG (|b| |lines| |LETTMP#1|) @@ -140,16 +136,15 @@ (COND ((OR (NULL |x|) (EQCAR |x| '|nullstream|)) T) ('T - (PROGN - (LOOP - (COND - ((NOT (EQCAR |x| '|nonnullstream|)) (RETURN NIL)) - ('T - (PROGN - (SETQ |st| (APPLY (CADR |x|) (CDDR |x|))) - (RPLACA |x| (CAR |st|)) - (RPLACD |x| (CDR |st|)))))) - (EQCAR |x| '|nullstream|))))))) + (LOOP + (COND + ((NOT (EQCAR |x| '|nonnullstream|)) (RETURN NIL)) + ('T + (PROGN + (SETQ |st| (APPLY (CADR |x|) (CDDR |x|))) + (RPLACA |x| (CAR |st|)) + (RPLACD |x| (CDR |st|)))))) + (EQCAR |x| '|nullstream|)))))) (DEFUN |bMap| (|f| |x|) (|bDelay| #'|bMap1| (LIST |f| |x|))) @@ -171,16 +166,12 @@ (PROGN (SETQ |a| (|shoeInputFile| |fn|)) (COND - ((NULL |a|) - (PROGN - (|shoeConsole| (CONCAT |fn| " NOT FOUND")) - |$bStreamNil|)) - ('T - (PROGN - (|shoeConsole| (CONCAT "READING " |fn|)) - (|shoeInclude| - (|bAddLineNumber| (|bMap| |f| (|bRgen| |a|)) - (|bIgen| 0)))))))))) + ((NULL |a|) (|shoeConsole| (CONCAT |fn| " NOT FOUND")) + |$bStreamNil|) + ('T (|shoeConsole| (CONCAT "READING " |fn|)) + (|shoeInclude| + (|bAddLineNumber| (|bMap| |f| (|bRgen| |a|)) + (|bIgen| 0))))))))) (DEFUN |bDelay| (|f| |x|) (CONS '|nonnullstream| (CONS |f| |x|))) @@ -201,10 +192,8 @@ (RETURN (COND ((|bStreamNull| |s|) (LIST '|nullstream|)) - ('T - (PROGN - (SETQ |h| (APPLY |f| (LIST |s|))) - (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|))))))))) + ('T (SETQ |h| (APPLY |f| (LIST |s|))) + (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|)))))))) (DEFUN |bRgen| (|s|) (|bDelay| #'|bRgen1| (LIST |s|))) @@ -255,21 +244,19 @@ (RETURN (COND ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL) - ('T - (PROGN - (SETQ |good| T) - (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0)) - (LOOP - (COND - ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL)) - ('T - (SETQ |good| - (EQUAL (ELT |prefix| |i|) (ELT |whole| |j|))))) - (SETQ |i| (+ |i| 1)) - (SETQ |j| (+ |j| 1)))) - (COND - (|good| (SUBSTRING |whole| (LENGTH |prefix|) NIL)) - ('T |good|)))))))) + ('T (SETQ |good| T) + (LET ((|bfVar#1| (- (LENGTH |prefix|) 1)) (|i| 0) (|j| 0)) + (LOOP + (COND + ((OR (> |i| |bfVar#1|) (NOT |good|)) (RETURN NIL)) + ('T + (SETQ |good| + (EQUAL (ELT |prefix| |i|) (ELT |whole| |j|))))) + (SETQ |i| (+ |i| 1)) + (SETQ |j| (+ |j| 1)))) + (COND + (|good| (SUBSTRING |whole| (LENGTH |prefix|) NIL)) + ('T |good|))))))) (DEFUN |shoePlainLine?| (|s|) (COND @@ -312,14 +299,12 @@ (SETQ |n| (STRPOSL " " |x| 0 T)) (COND ((NULL |n|) NIL) - (#0='T - (PROGN - (SETQ |n1| (STRPOSL " " |x| |n| NIL)) - (COND - ((NULL |n1|) (LIST (SUBSTRING |x| |n| NIL) "")) - (#0# - (LIST (SUBSTRING |x| |n| (- |n1| |n|)) - (SUBSTRING |x| |n1| NIL))))))))))) + (#0='T (SETQ |n1| (STRPOSL " " |x| |n| NIL)) + (COND + ((NULL |n1|) (LIST (SUBSTRING |x| |n| NIL) "")) + (#0# + (LIST (SUBSTRING |x| |n| (- |n1| |n|)) + (SUBSTRING |x| |n1| NIL)))))))))) (DEFUN |shoeFileName| (|x|) (PROG (|c| |a|) @@ -328,12 +313,10 @@ (SETQ |a| (|shoeBiteOff| |x|)) (COND ((NULL |a|) "") - (#0='T - (PROGN - (SETQ |c| (|shoeBiteOff| (CADR |a|))) - (COND - ((NULL |c|) (CAR |a|)) - (#0# (CONCAT (CAR |a|) "." (CAR |c|))))))))))) + (#0='T (SETQ |c| (|shoeBiteOff| (CADR |a|))) + (COND + ((NULL |c|) (CAR |a|)) + (#0# (CONCAT (CAR |a|) "." (CAR |c|)))))))))) (DEFUN |shoeFnFileName| (|x|) (PROG (|c| |a|) @@ -342,12 +325,10 @@ (SETQ |a| (|shoeBiteOff| |x|)) (COND ((NULL |a|) (LIST "" "")) - (#0='T - (PROGN - (SETQ |c| (|shoeFileName| (CADR |a|))) - (COND - ((NULL |c|) (LIST (CAR |a|) "")) - (#0# (LIST (CAR |a|) |c|)))))))))) + (#0='T (SETQ |c| (|shoeFileName| (CADR |a|))) + (COND + ((NULL |c|) (LIST (CAR |a|) "")) + (#0# (LIST (CAR |a|) |c|))))))))) (DEFUN |shoeFunctionFileInput| (|bfVar#2|) (PROG (|fn| |fun|) @@ -368,17 +349,13 @@ (RETURN (COND ((|bStreamNull| |s|) |s|) - (#0='T - (PROGN - (SETQ |h| (CAR |s|)) - (SETQ |t| (CDR |s|)) - (SETQ |string| (CAR |h|)) - (COND - ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|) - ((SETQ |command| (|shoeIf?| |string|)) - (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|)) - (#0# - (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|)))))))))) + (#0='T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|)) + (SETQ |string| (CAR |h|)) + (COND + ((SETQ |command| (|shoeFin?| |string|)) |$bStreamNil|) + ((SETQ |command| (|shoeIf?| |string|)) + (|shoeThen| (LIST T) (LIST (STTOMC |command|)) |t|)) + (#0# (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|))))))))) (DEFUN |shoeSimpleLine| (|h|) (PROG (|command| |string|) @@ -399,10 +376,10 @@ (|shoeFileInput| (|shoeFileName| |command|))) ((SETQ |command| (|shoePackage?| |string|)) (LIST |h|)) ((SETQ |command| (|shoeSay?| |string|)) - (PROGN (|shoeConsole| |command|) NIL)) - ((SETQ |command| (|shoeEval?| |string|)) - (PROGN (STTOMC |command|) NIL)) - ('T (PROGN (|shoeLineSyntaxError| |h|) NIL))))))) + (|shoeConsole| |command|) NIL) + ((SETQ |command| (|shoeEval?| |string|)) (STTOMC |command|) + NIL) + ('T (|shoeLineSyntaxError| |h|) NIL)))))) (DEFUN |shoeThen| (|keep| |b| |s|) (|bDelay| #'|shoeThen1| (LIST |keep| |b| |s|))) @@ -412,50 +389,44 @@ (RETURN (COND ((|bPremStreamNull| |s|) |s|) - (#0='T - (PROGN - (SETQ |h| (CAR |s|)) - (SETQ |t| (CDR |s|)) - (SETQ |string| (CAR |h|)) - (COND - ((SETQ |command| (|shoeFin?| |string|)) - (|bPremStreamNil| |h|)) - (#0# - (PROGN - (SETQ |keep1| (CAR |keep|)) - (SETQ |b1| (CAR |b|)) - (COND - ((SETQ |command| (|shoeIf?| |string|)) - (COND - ((AND |keep1| |b1|) - (|shoeThen| (CONS T |keep|) - (CONS (STTOMC |command|) |b|) |t|)) - (#0# - (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|)))) - ((SETQ |command| (|shoeElseIf?| |string|)) - (COND - ((AND |keep1| (NOT |b1|)) - (|shoeThen| (CONS T (CDR |keep|)) - (CONS (STTOMC |command|) (CDR |b|)) |t|)) - (#0# - (|shoeThen| (CONS NIL (CDR |keep|)) - (CONS NIL (CDR |b|)) |t|)))) - ((SETQ |command| (|shoeElse?| |string|)) - (COND - ((AND |keep1| (NOT |b1|)) - (|shoeElse| (CONS T (CDR |keep|)) - (CONS T (CDR |b|)) |t|)) - (#0# - (|shoeElse| (CONS NIL (CDR |keep|)) - (CONS NIL (CDR |b|)) |t|)))) - ((SETQ |command| (|shoeEndIf?| |string|)) - (COND - ((NULL (CDR |b|)) (|shoeInclude| |t|)) - (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) - ((AND |keep1| |b1|) - (|bAppend| (|shoeSimpleLine| |h|) - (|shoeThen| |keep| |b| |t|))) - (#0# (|shoeThen| |keep| |b| |t|)))))))))))) + (#0='T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|)) + (SETQ |string| (CAR |h|)) + (COND + ((SETQ |command| (|shoeFin?| |string|)) + (|bPremStreamNil| |h|)) + (#0# (SETQ |keep1| (CAR |keep|)) (SETQ |b1| (CAR |b|)) + (COND + ((SETQ |command| (|shoeIf?| |string|)) + (COND + ((AND |keep1| |b1|) + (|shoeThen| (CONS T |keep|) + (CONS (STTOMC |command|) |b|) |t|)) + (#0# + (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|)))) + ((SETQ |command| (|shoeElseIf?| |string|)) + (COND + ((AND |keep1| (NOT |b1|)) + (|shoeThen| (CONS T (CDR |keep|)) + (CONS (STTOMC |command|) (CDR |b|)) |t|)) + (#0# + (|shoeThen| (CONS NIL (CDR |keep|)) + (CONS NIL (CDR |b|)) |t|)))) + ((SETQ |command| (|shoeElse?| |string|)) + (COND + ((AND |keep1| (NOT |b1|)) + (|shoeElse| (CONS T (CDR |keep|)) (CONS T (CDR |b|)) + |t|)) + (#0# + (|shoeElse| (CONS NIL (CDR |keep|)) + (CONS NIL (CDR |b|)) |t|)))) + ((SETQ |command| (|shoeEndIf?| |string|)) + (COND + ((NULL (CDR |b|)) (|shoeInclude| |t|)) + (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) + ((AND |keep1| |b1|) + (|bAppend| (|shoeSimpleLine| |h|) + (|shoeThen| |keep| |b| |t|))) + (#0# (|shoeThen| |keep| |b| |t|)))))))))) (DEFUN |shoeElse| (|keep| |b| |s|) (|bDelay| #'|shoeElse1| (LIST |keep| |b| |s|))) @@ -465,34 +436,28 @@ (RETURN (COND ((|bPremStreamNull| |s|) |s|) - (#0='T - (PROGN - (SETQ |h| (CAR |s|)) - (SETQ |t| (CDR |s|)) - (SETQ |string| (CAR |h|)) - (COND - ((SETQ |command| (|shoeFin?| |string|)) - (|bPremStreamNil| |h|)) - (#0# - (PROGN - (SETQ |b1| (CAR |b|)) - (SETQ |keep1| (CAR |keep|)) - (COND - ((SETQ |command| (|shoeIf?| |string|)) - (COND - ((AND |keep1| |b1|) - (|shoeThen| (CONS T |keep|) - (CONS (STTOMC |command|) |b|) |t|)) - (#0# - (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|)))) - ((SETQ |command| (|shoeEndIf?| |string|)) - (COND - ((NULL (CDR |b|)) (|shoeInclude| |t|)) - (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) - ((AND |keep1| |b1|) - (|bAppend| (|shoeSimpleLine| |h|) - (|shoeElse| |keep| |b| |t|))) - (#0# (|shoeElse| |keep| |b| |t|)))))))))))) + (#0='T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|)) + (SETQ |string| (CAR |h|)) + (COND + ((SETQ |command| (|shoeFin?| |string|)) + (|bPremStreamNil| |h|)) + (#0# (SETQ |b1| (CAR |b|)) (SETQ |keep1| (CAR |keep|)) + (COND + ((SETQ |command| (|shoeIf?| |string|)) + (COND + ((AND |keep1| |b1|) + (|shoeThen| (CONS T |keep|) + (CONS (STTOMC |command|) |b|) |t|)) + (#0# + (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|)))) + ((SETQ |command| (|shoeEndIf?| |string|)) + (COND + ((NULL (CDR |b|)) (|shoeInclude| |t|)) + (#0# (|shoeThen| (CDR |keep|) (CDR |b|) |t|)))) + ((AND |keep1| |b1|) + (|bAppend| (|shoeSimpleLine| |h|) + (|shoeElse| |keep| |b| |t|))) + (#0# (|shoeElse| |keep| |b| |t|)))))))))) (DEFUN |shoeLineSyntaxError| (|h|) (PROGN diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index 36bece77..15e77276 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -35,10 +35,10 @@ (COND ((AND (< 0 |$bpParenCount|) (EQCAR |$stok| 'KEY)) (COND - ((EQ |$ttok| 'SETTAB) - (PROGN (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|))) - ((EQ |$ttok| 'BACKTAB) - (PROGN (SETQ |$bpCount| (- |$bpCount| 1)) (|bpNext|))) + ((EQ |$ttok| 'SETTAB) (SETQ |$bpCount| (+ |$bpCount| 1)) + (|bpNext|)) + ((EQ |$ttok| 'BACKTAB) (SETQ |$bpCount| (- |$bpCount| 1)) + (|bpNext|)) ((EQ |$ttok| 'BACKSET) (|bpNext|)) (#0='T T))) (#0# T)))) @@ -119,14 +119,13 @@ (COND ((EQL |$bpCount| 0) T) (#0='T - (PROGN - (SETQ |$inputStream| - (APPEND (|bpAddTokens| |$bpCount|) - |$inputStream|)) - (|bpFirstToken|) - (COND - ((EQL |$bpParenCount| 0) (PROGN (|bpCancel|) T)) - (#0# T)))))) + (SETQ |$inputStream| + (APPEND (|bpAddTokens| |$bpCount|) + |$inputStream|)) + (|bpFirstToken|) + (COND + ((EQL |$bpParenCount| 0) (|bpCancel|) T) + (#0# T))))) ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL)) (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|) T) @@ -244,13 +243,10 @@ (DECLARE (SPECIAL |$stack|)) (RETURN (COND - ((APPLY |f| NIL) - (PROGN - (SETQ |a| |$stack|) - (SETQ |$stack| NIL) - (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) ('T 0))) - (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) - (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))) + ((APPLY |f| NIL) (SETQ |a| |$stack|) (SETQ |$stack| NIL) + (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) ('T 0))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) ('T NIL))))) (DEFUN |bpAnyNo| (|s|) @@ -380,61 +376,45 @@ ((|bpEqPeek| 'BACKTAB) (COND ((EQL |n| 0) T) - (#0='T - (PROGN - (|bpNextToken|) - (SETQ |$bpCount| (- |$bpCount| 1)) - (|bpMoveTo| (- |n| 1)))))) + (#0='T (|bpNextToken|) (SETQ |$bpCount| (- |$bpCount| 1)) + (|bpMoveTo| (- |n| 1))))) ((|bpEqPeek| 'BACKSET) - (COND - ((EQL |n| 0) T) - (#0# (PROGN (|bpNextToken|) (|bpMoveTo| |n|))))) - ((|bpEqPeek| 'SETTAB) - (PROGN (|bpNextToken|) (|bpMoveTo| (+ |n| 1)))) - ((|bpEqPeek| 'OPAREN) - (PROGN - (|bpNextToken|) - (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) - (|bpMoveTo| |n|))) - ((|bpEqPeek| 'CPAREN) - (PROGN - (|bpNextToken|) - (SETQ |$bpParenCount| (- |$bpParenCount| 1)) - (|bpMoveTo| |n|))) - (#0# (PROGN (|bpNextToken|) (|bpMoveTo| |n|))))) + (COND ((EQL |n| 0) T) (#0# (|bpNextToken|) (|bpMoveTo| |n|)))) + ((|bpEqPeek| 'SETTAB) (|bpNextToken|) (|bpMoveTo| (+ |n| 1))) + ((|bpEqPeek| 'OPAREN) (|bpNextToken|) + (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) (|bpMoveTo| |n|)) + ((|bpEqPeek| 'CPAREN) (|bpNextToken|) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpMoveTo| |n|)) + (#0# (|bpNextToken|) (|bpMoveTo| |n|)))) (DEFUN |bpQualifiedName| () (DECLARE (SPECIAL |$stok|)) (COND - ((|bpEqPeek| 'COLON-COLON) - (PROGN - (|bpNext|) - (AND (EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|) - (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|)))))) + ((|bpEqPeek| 'COLON-COLON) (|bpNext|) + (AND (EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|) + (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|))))) ('T NIL))) (DEFUN |bpName| () (DECLARE (SPECIAL |$stok|)) (COND - ((EQCAR |$stok| 'ID) - (PROGN (|bpPushId|) (|bpNext|) (|bpAnyNo| #'|bpQualifiedName|))) + ((EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|) + (|bpAnyNo| #'|bpQualifiedName|)) ('T NIL))) (DEFUN |bpConstTok| () (DECLARE (SPECIAL |$ttok| |$stok|)) (COND - ((MEMQ (|shoeTokType| |$stok|) '(INTEGER FLOAT)) - (PROGN (|bpPush| |$ttok|) (|bpNext|))) + ((MEMQ (|shoeTokType| |$stok|) '(INTEGER FLOAT)) (|bpPush| |$ttok|) + (|bpNext|)) ((EQCAR |$stok| 'LISP) (AND (|bpPush| (|%Lisp| |$ttok|)) (|bpNext|))) ((EQCAR |$stok| 'LISPEXP) (AND (|bpPush| |$ttok|) (|bpNext|))) ((EQCAR |$stok| 'LINE) (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|))) - ((|bpEqPeek| 'QUOTE) - (PROGN - (|bpNext|) - (AND (OR (|bpSexp|) (|bpTrap|)) - (|bpPush| (|bfSymbol| (|bpPop1|)))))) + ((|bpEqPeek| 'QUOTE) (|bpNext|) + (AND (OR (|bpSexp|) (|bpTrap|)) + (|bpPush| (|bfSymbol| (|bpPop1|))))) ('T (|bpString|)))) (DEFUN |bpExportItemTail| () @@ -447,19 +427,15 @@ (RETURN (COND ((|bpEqPeek| 'STRUCTURE) (|bpStruct|)) - (#0='T - (PROGN - (SETQ |a| (|bpState|)) - (COND - ((|bpName|) - (COND - ((|bpEqPeek| 'COLON) - (PROGN - (|bpRestore| |a|) - (OR (|bpSignature|) (|bpTrap|)) - (OR (|bpExportItemTail|) T))) - (#0# (PROGN (|bpRestore| |a|) (|bpTypeAliasDefition|))))) - (#0# NIL)))))))) + (#0='T (SETQ |a| (|bpState|)) + (COND + ((|bpName|) + (COND + ((|bpEqPeek| 'COLON) (|bpRestore| |a|) + (OR (|bpSignature|) (|bpTrap|)) + (OR (|bpExportItemTail|) T)) + (#0# (|bpRestore| |a|) (|bpTypeAliasDefition|)))) + (#0# NIL))))))) (DEFUN |bpExportItemList| () (|bpListAndRecover| #'|bpExportItem|)) @@ -481,20 +457,15 @@ (PROG (|a|) (RETURN (COND - ((|bpEqKey| 'IMPORT) - (PROGN - (SETQ |a| (|bpState|)) - (OR (|bpName|) (|bpTrap|)) - (COND - ((|bpEqPeek| 'COLON) - (PROGN - (|bpRestore| |a|) - (AND (OR (|bpSignature|) (|bpTrap|)) - (OR (|bpEqKey| 'FOR) (|bpTrap|)) - (OR (|bpName|) (|bpTrap|)) - (|bpPush| - (|%ImportSignature| (|bpPop1|) (|bpPop1|)))))) - (#0='T (|bpPush| (|%Import| (|bpPop1|))))))) + ((|bpEqKey| 'IMPORT) (SETQ |a| (|bpState|)) + (OR (|bpName|) (|bpTrap|)) + (COND + ((|bpEqPeek| 'COLON) (|bpRestore| |a|) + (AND (OR (|bpSignature|) (|bpTrap|)) + (OR (|bpEqKey| 'FOR) (|bpTrap|)) + (OR (|bpName|) (|bpTrap|)) + (|bpPush| (|%ImportSignature| (|bpPop1|) (|bpPop1|))))) + (#0='T (|bpPush| (|%Import| (|bpPop1|)))))) (#0# NIL))))) (DEFUN |bpNamespace| () @@ -512,10 +483,9 @@ (DEFUN |bpSimpleMapping| () (COND ((|bpApplication|) - (PROGN - (AND (|bpEqKey| 'ARROW) (OR (|bpApplication|) (|bpTrap|)) - (|bpPush| (|%Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|))))) - T)) + (AND (|bpEqKey| 'ARROW) (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|%Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|))))) + T) ('T NIL))) (DEFUN |bpArgtypeList| () (|bpTuple| #'|bpApplication|)) @@ -564,11 +534,10 @@ (RETURN (COND ((AND (EQCAR |$stok| 'KEY) (NOT (|bpExceptions|))) - (PROGN - (SETQ |a| (GET |$ttok| 'SHOEINF)) - (COND - ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|))) - (#0='T (AND (|bpPush| |a|) (|bpNext|)))))) + (SETQ |a| (GET |$ttok| 'SHOEINF)) + (COND + ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|))) + (#0='T (AND (|bpPush| |a|) (|bpNext|))))) (#0# NIL))))) (DEFUN |bpAnyId| () @@ -878,12 +847,12 @@ (COND ((|bpExit|) (COND - ((|bpEqPeek| 'DEF) (PROGN (|bpRestore| |a|) (|bpDef|))) - ((|bpEqPeek| 'TDEF) - (PROGN (|bpRestore| |a|) (|bpTypeAliasDefition|))) - ((|bpEqPeek| 'MDEF) (PROGN (|bpRestore| |a|) (|bpMdef|))) + ((|bpEqPeek| 'DEF) (|bpRestore| |a|) (|bpDef|)) + ((|bpEqPeek| 'TDEF) (|bpRestore| |a|) + (|bpTypeAliasDefition|)) + ((|bpEqPeek| 'MDEF) (|bpRestore| |a|) (|bpMdef|)) (#0='T T))) - (#0# (PROGN (|bpRestore| |a|) NIL))))))) + (#0# (|bpRestore| |a|) NIL)))))) (DEFUN |bpStoreName| () (DECLARE (SPECIAL |$typings| |$wheredefs| |$op| |$stack|)) diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp index 5590d0ca..21722a2a 100644 --- a/src/boot/strap/scanner.clisp +++ b/src/boot/strap/scanner.clisp @@ -50,12 +50,11 @@ (COND ((NULL |$n|) T) ((EQUAL (QENUM |$ln| |$n|) |shoeTAB|) - (PROGN - (SETQ |a| (MAKE-FULL-CVEC (- 7 (REM |$n| 8)) " ")) - (SETF (ELT |$ln| |$n|) (ELT " " 0)) - (SETQ |$ln| (CONCAT |a| |$ln|)) - (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|)) - (|shoeNextLine| |s1|))) + (SETQ |a| (MAKE-FULL-CVEC (- 7 (REM |$n| 8)) " ")) + (SETF (ELT |$ln| |$n|) (ELT " " 0)) + (SETQ |$ln| (CONCAT |a| |$ln|)) + (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|)) + (|shoeNextLine| |s1|)) ('T T))))))) (DEFUN |shoeLineToks| (|s|) @@ -74,41 +73,34 @@ (COND ((NOT (|shoeNextLine| |s|)) (CONS NIL NIL)) ((NULL |$n|) (|shoeLineToks| |$r|)) - (#0='T - (PROGN - (SETQ |fst| (QENUM |$ln| 0)) - (COND - ((EQL |fst| |shoeCLOSEPAREN|) + (#0='T (SETQ |fst| (QENUM |$ln| 0)) + (COND + ((EQL |fst| |shoeCLOSEPAREN|) + (COND + ((SETQ |command| (|shoeLine?| |$ln|)) + (SETQ |dq| + (|dqUnit| + (|shoeConstructToken| |$ln| |$linepos| + (|shoeLeafLine| |command|) 0))) + (CONS (LIST |dq|) |$r|)) + ((SETQ |command| (|shoeLisp?| |$ln|)) + (|shoeLispToken| |$r| |command|)) + ((SETQ |command| (|shoePackage?| |$ln|)) + (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")")) + (SETQ |dq| + (|dqUnit| + (|shoeConstructToken| |$ln| |$linepos| + (|shoeLeafLisp| |a|) 0))) + (CONS (LIST |dq|) |$r|)) + (#0# (|shoeLineToks| |$r|)))) + (#0# (SETQ |toks| NIL) + (LOOP (COND - ((SETQ |command| (|shoeLine?| |$ln|)) - (PROGN - (SETQ |dq| - (|dqUnit| - (|shoeConstructToken| |$ln| |$linepos| - (|shoeLeafLine| |command|) 0))) - (CONS (LIST |dq|) |$r|))) - ((SETQ |command| (|shoeLisp?| |$ln|)) - (|shoeLispToken| |$r| |command|)) - ((SETQ |command| (|shoePackage?| |$ln|)) - (PROGN - (SETQ |a| (CONCAT "(IN-PACKAGE " |command| ")")) - (SETQ |dq| - (|dqUnit| - (|shoeConstructToken| |$ln| |$linepos| - (|shoeLeafLisp| |a|) 0))) - (CONS (LIST |dq|) |$r|))) - (#0# (|shoeLineToks| |$r|)))) - (#0# - (PROGN - (SETQ |toks| NIL) - (LOOP - (COND - ((NOT (< |$n| |$sz|)) (RETURN NIL)) - ('T - (SETQ |toks| (|dqAppend| |toks| (|shoeToken|)))))) - (COND - ((NULL |toks|) (|shoeLineToks| |$r|)) - (#0# (CONS (LIST |toks|) |$r|))))))))))))) + ((NOT (< |$n| |$sz|)) (RETURN NIL)) + ('T (SETQ |toks| (|dqAppend| |toks| (|shoeToken|)))))) + (COND + ((NULL |toks|) (|shoeLineToks| |$r|)) + (#0# (CONS (LIST |toks|) |$r|))))))))))) (DEFUN |shoeLispToken| (|s| |string|) (PROG (|dq| |st| |r| |LETTMP#1| |linepos| |ln|) @@ -140,30 +132,25 @@ ((NOT (|shoeNextLine| |s|)) (CONS |s| |string|)) ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|)) ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|)) - (#0='T - (PROGN - (SETQ |fst| (QENUM |$ln| 0)) - (COND - ((EQL |fst| |shoeCLOSEPAREN|) - (PROGN - (SETQ |command| (|shoeLisp?| |$ln|)) - (COND - ((AND |command| (< 0 (LENGTH |command|))) - (COND - ((EQL (QENUM |command| 0) (QENUM ";" 0)) - (|shoeAccumulateLines| |$r| |string|)) - (#0# - (PROGN - (SETQ |a| (STRPOS ";" |command| 0 NIL)) - (COND - (|a| (|shoeAccumulateLines| |$r| - (CONCAT |string| - (SUBSTRING |command| 0 (- |a| 1))))) - (#0# - (|shoeAccumulateLines| |$r| - (CONCAT |string| |command|)))))))) - (#0# (|shoeAccumulateLines| |$r| |string|))))) - (#0# (CONS |s| |string|))))))))) + (#0='T (SETQ |fst| (QENUM |$ln| 0)) + (COND + ((EQL |fst| |shoeCLOSEPAREN|) + (SETQ |command| (|shoeLisp?| |$ln|)) + (COND + ((AND |command| (< 0 (LENGTH |command|))) + (COND + ((EQL (QENUM |command| 0) (QENUM ";" 0)) + (|shoeAccumulateLines| |$r| |string|)) + (#0# (SETQ |a| (STRPOS ";" |command| 0 NIL)) + (COND + (|a| (|shoeAccumulateLines| |$r| + (CONCAT |string| + (SUBSTRING |command| 0 (- |a| 1))))) + (#0# + (|shoeAccumulateLines| |$r| + (CONCAT |string| |command|))))))) + (#0# (|shoeAccumulateLines| |$r| |string|)))) + (#0# (CONS |s| |string|)))))))) (DEFUN |shoeCloser| (|t|) (MEMBER (|shoeKeyWord| |t|) '(CPAREN CBRACK))) @@ -180,18 +167,16 @@ (SETQ |ch| (ELT |$ln| |$n|)) (SETQ |b| (COND - ((|shoeStartsComment|) (PROGN (|shoeComment|) NIL)) - ((|shoeStartsNegComment|) - (PROGN (|shoeNegComment|) NIL)) + ((|shoeStartsComment|) (|shoeComment|) NIL) + ((|shoeStartsNegComment|) (|shoeNegComment|) NIL) ((EQUAL |c| |shoeLispESCAPE|) (|shoeLispEscape|)) ((|shoePunctuation| |c|) (|shoePunct|)) ((|shoeStartsId| |ch|) (|shoeWord| NIL)) - ((EQUAL |c| |shoeSPACE|) (PROGN (|shoeSpace|) NIL)) + ((EQUAL |c| |shoeSPACE|) (|shoeSpace|) NIL) ((EQUAL |c| |shoeSTRINGCHAR|) (|shoeString|)) ((|shoeDigit| |ch|) (|shoeNumber|)) ((EQUAL |c| |shoeESCAPE|) (|shoeEscape|)) - ((EQUAL |c| |shoeTAB|) - (PROGN (SETQ |$n| (+ |$n| 1)) NIL)) + ((EQUAL |c| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL) (#0='T (|shoeError|)))) (COND ((NULL |b|) NIL) @@ -243,19 +228,14 @@ ('T (SETQ |a| (|shoeReadLispString| |$ln| |$n|)) (COND ((NULL |a|) - (PROGN - (|SoftShoeError| (CONS |$linepos| |$n|) - "lisp escape error") - (|shoeLeafError| (ELT |$ln| |$n|)))) - (#0='T - (PROGN - (SETQ |exp| (CAR |a|)) - (SETQ |n| (CADR |a|)) - (COND - ((NULL |n|) - (PROGN (SETQ |$n| |$sz|) (|shoeLeafLispExp| |exp|))) - (#0# - (PROGN (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|))))))))))))) + (|SoftShoeError| (CONS |$linepos| |$n|) + "lisp escape error") + (|shoeLeafError| (ELT |$ln| |$n|))) + (#0='T (SETQ |exp| (CAR |a|)) (SETQ |n| (CADR |a|)) + (COND + ((NULL |n|) (SETQ |$n| |$sz|) + (|shoeLeafLispExp| |exp|)) + (#0# (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|))))))))))) (DEFUN |shoeEscape| () (PROG (|a|) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index 4b5ae83a..dfb850cb 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -28,59 +28,58 @@ ((NULL |$currentModuleName|) (|coreError| "current module has no name")) (#0='T - (PROGN - (SETQ |init| - (CONS 'DEFUN - (CONS (INTERN (CONCAT |$currentModuleName| - '|InitCLispFFI|)) - (CONS NIL - (CONS - (LIST 'MAPC - (LIST 'FUNCTION 'FMAKUNBOUND) - (LIST 'QUOTE - (LET - ((|bfVar#2| NIL) - (|bfVar#1| - |$foreignsDefsForCLisp|) - (|d| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#1|) - (PROGN - (SETQ |d| - (CAR |bfVar#1|)) - NIL)) - (RETURN - (NREVERSE |bfVar#2|))) - (#1='T - (SETQ |bfVar#2| - (CONS (CADR |d|) - |bfVar#2|)))) - (SETQ |bfVar#1| - (CDR |bfVar#1|)))))) + (SETQ |init| + (CONS 'DEFUN + (CONS (INTERN (CONCAT |$currentModuleName| + '|InitCLispFFI|)) + (CONS NIL + (CONS + (LIST 'MAPC + (LIST 'FUNCTION 'FMAKUNBOUND) + (LIST 'QUOTE (LET - ((|bfVar#4| NIL) - (|bfVar#3| + ((|bfVar#2| NIL) + (|bfVar#1| |$foreignsDefsForCLisp|) (|d| NIL)) (LOOP (COND - ((OR (ATOM |bfVar#3|) + ((OR (ATOM |bfVar#1|) (PROGN (SETQ |d| - (CAR |bfVar#3|)) + (CAR |bfVar#1|)) NIL)) (RETURN - (NREVERSE |bfVar#4|))) - (#1# - (SETQ |bfVar#4| - (CONS - (LIST 'EVAL - (LIST 'QUOTE |d|)) - |bfVar#4|)))) - (SETQ |bfVar#3| - (CDR |bfVar#3|))))))))) - (REALLYPRETTYPRINT |init| |stream|))))) + (NREVERSE |bfVar#2|))) + (#1='T + (SETQ |bfVar#2| + (CONS (CADR |d|) + |bfVar#2|)))) + (SETQ |bfVar#1| + (CDR |bfVar#1|)))))) + (LET + ((|bfVar#4| NIL) + (|bfVar#3| + |$foreignsDefsForCLisp|) + (|d| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#3|) + (PROGN + (SETQ |d| + (CAR |bfVar#3|)) + NIL)) + (RETURN + (NREVERSE |bfVar#4|))) + (#1# + (SETQ |bfVar#4| + (CONS + (LIST 'EVAL + (LIST 'QUOTE |d|)) + |bfVar#4|)))) + (SETQ |bfVar#3| + (CDR |bfVar#3|))))))))) + (REALLYPRETTYPRINT |init| |stream|)))) (#0# NIL))))) (DEFUN |genOptimizeOptions| (|stream|) @@ -146,23 +145,21 @@ (DECLARE (SPECIAL |$GenVarCounter|)) (COND ((NULL |a|) (|shoeNotFound| |fn|)) - ('T - (PROGN - (SETQ |$GenVarCounter| 0) - (|shoeOpenOutputFile| |stream| |outfn| - (PROGN - (|genOptimizeOptions| |stream|) - (LET ((|bfVar#5| |lines|) (|line| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#5|) - (PROGN (SETQ |line| (CAR |bfVar#5|)) NIL)) - (RETURN NIL)) - ('T (|shoeFileLine| |line| |stream|))) - (SETQ |bfVar#5| (CDR |bfVar#5|)))) - (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|) - (|genModuleFinalization| |stream|))) - |outfn|)))) + ('T (SETQ |$GenVarCounter| 0) + (|shoeOpenOutputFile| |stream| |outfn| + (PROGN + (|genOptimizeOptions| |stream|) + (LET ((|bfVar#5| |lines|) (|line| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#5|) + (PROGN (SETQ |line| (CAR |bfVar#5|)) NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| |line| |stream|))) + (SETQ |bfVar#5| (CDR |bfVar#5|)))) + (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|) + (|genModuleFinalization| |stream|))) + |outfn|))) (DEFUN BOOTTOCLC (|fn| |out|) (PROG (|result| |callingPackage|) @@ -189,27 +186,25 @@ (DECLARE (SPECIAL |$GenVarCounter|)) (COND ((NULL |a|) (|shoeNotFound| |fn|)) - ('T - (PROGN - (SETQ |$GenVarCounter| 0) - (|shoeOpenOutputFile| |stream| |outfn| - (PROGN - (|genOptimizeOptions| |stream|) - (LET ((|bfVar#6| |lines|) (|line| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#6|) - (PROGN (SETQ |line| (CAR |bfVar#6|)) NIL)) - (RETURN NIL)) - ('T (|shoeFileLine| |line| |stream|))) - (SETQ |bfVar#6| (CDR |bfVar#6|)))) - (|shoeFileTrees| - (|shoeTransformToFile| |stream| - (|shoeInclude| - (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))) - |stream|) - (|genModuleFinalization| |stream|))) - |outfn|)))) + ('T (SETQ |$GenVarCounter| 0) + (|shoeOpenOutputFile| |stream| |outfn| + (PROGN + (|genOptimizeOptions| |stream|) + (LET ((|bfVar#6| |lines|) (|line| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#6|) + (PROGN (SETQ |line| (CAR |bfVar#6|)) NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| |line| |stream|))) + (SETQ |bfVar#6| (CDR |bfVar#6|)))) + (|shoeFileTrees| + (|shoeTransformToFile| |stream| + (|shoeInclude| + (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0)))) + |stream|) + (|genModuleFinalization| |stream|))) + |outfn|))) (DECLAIM (FTYPE (FUNCTION (|%String|) |%Thing|) BOOTTOMC)) @@ -230,10 +225,8 @@ (DEFUN |shoeMc| (|a| |fn|) (COND ((NULL |a|) (|shoeNotFound| |fn|)) - ('T - (PROGN - (|shoePCompileTrees| (|shoeTransformStream| |a|)) - (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED")))))) + ('T (|shoePCompileTrees| (|shoeTransformStream| |a|)) + (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED"))))) (DEFUN EVAL-BOOT-FILE (|fn|) (PROG (|outfn| |infn| |b|) @@ -322,11 +315,10 @@ (COND ((|bStreamNull| |a|) NIL) ('T - (PROGN - (SETQ |fn| - (|stripm| (CAR |a|) *PACKAGE* - (FIND-PACKAGE "BOOTTRAN"))) - (EVAL |fn|))))) + (SETQ |fn| + (|stripm| (CAR |a|) *PACKAGE* + (FIND-PACKAGE "BOOTTRAN"))) + (EVAL |fn|)))) (|setCurrentPackage| |callingPackage|) |result|)))) @@ -409,12 +401,10 @@ (RETURN (COND ((|bStreamNull| |s|) (LIST '|nullstream|)) - ('T - (PROGN - (SETQ |dq| (CAR |s|)) - (|shoeFileLines| (|shoeDQlines| |dq|) |fn|) - (|bAppend| (|shoeParseTrees| |dq|) - (|bFileNext| |fn| (CDR |s|))))))))) + ('T (SETQ |dq| (CAR |s|)) + (|shoeFileLines| (|shoeDQlines| |dq|) |fn|) + (|bAppend| (|shoeParseTrees| |dq|) + (|bFileNext| |fn| (CDR |s|)))))))) (DEFUN |shoeParseTrees| (|dq|) (PROG (|toklist|) @@ -524,9 +514,9 @@ (SETQ |found| (CATCH 'TRAPPOINT (|bpOutItem|))) (COND ((EQ |found| 'TRAPPED) NIL) - ((NOT (|bStreamNull| |$inputStream|)) - (PROGN (|bpGeneralErrorHere|) NIL)) - ((NULL |$stack|) (PROGN (|bpGeneralErrorHere|) NIL)) + ((NOT (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|) + NIL) + ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) ('T (CAR |$stack|))))))) (DEFUN |genDeclaration| (|n| |t|) @@ -544,16 +534,13 @@ (PROGN (SETQ |argTypes| (CAR |ISTMP#2|)) 'T)))))) - (PROGN - (COND - ((|bfTupleP| |argTypes|) - (SETQ |argTypes| (CDR |argTypes|)))) - (COND - ((AND (NOT (NULL |argTypes|)) (SYMBOLP |argTypes|)) - (SETQ |argTypes| (LIST |argTypes|)))) - (LIST 'DECLAIM - (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|) - |n|)))) + (COND + ((|bfTupleP| |argTypes|) (SETQ |argTypes| (CDR |argTypes|)))) + (COND + ((AND (NOT (NULL |argTypes|)) (SYMBOLP |argTypes|)) + (SETQ |argTypes| (LIST |argTypes|)))) + (LIST 'DECLAIM + (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|) |n|))) ('T (LIST 'DECLAIM (LIST 'TYPE |t| |n|))))))) (DEFUN |translateSignatureDeclaration| (|d|) @@ -758,21 +745,17 @@ (RETURN (COND ((NULL |a|) (|shoeNotFound| |fn|)) - ('T - (PROGN - (SETQ |$lispWordTable| (MAKE-HASHTABLE 'EQ)) - (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP)) - (HPUT |$lispWordTable| |i| T)) - (SETQ |$bootDefined| (MAKE-HASHTABLE 'EQ)) - (SETQ |$bootUsed| (MAKE-HASHTABLE 'EQ)) - (SETQ |$bootDefinedTwice| NIL) - (SETQ |$GenVarCounter| 0) - (SETQ |$bfClamming| NIL) - (|shoeDefUse| (|shoeTransformStream| |a|)) - (SETQ |out| (CONCAT |fn| ".defuse")) - (|shoeOpenOutputFile| |stream| |out| - (|shoeReport| |stream|)) - |out|)))))) + ('T (SETQ |$lispWordTable| (MAKE-HASHTABLE 'EQ)) + (DO-SYMBOLS (|i| (FIND-PACKAGE 'LISP)) + (HPUT |$lispWordTable| |i| T)) + (SETQ |$bootDefined| (MAKE-HASHTABLE 'EQ)) + (SETQ |$bootUsed| (MAKE-HASHTABLE 'EQ)) + (SETQ |$bootDefinedTwice| NIL) (SETQ |$GenVarCounter| 0) + (SETQ |$bfClamming| NIL) + (|shoeDefUse| (|shoeTransformStream| |a|)) + (SETQ |out| (CONCAT |fn| ".defuse")) + (|shoeOpenOutputFile| |stream| |out| (|shoeReport| |stream|)) + |out|))))) (DEFUN |shoeReport| (|stream|) (PROG (|b| |a|) @@ -960,19 +943,17 @@ (SETQ |a| (CAR |ISTMP#1|)) (SETQ |b| (CDR |ISTMP#1|)) #1#)))) - (PROGN - (SETQ |LETTMP#1| (|defSeparate| |a|)) - (SETQ |dol| (CAR |LETTMP#1|)) - (SETQ |ndol| (CADR |LETTMP#1|)) - (LET ((|bfVar#20| |dol|) (|i| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#20|) - (PROGN (SETQ |i| (CAR |bfVar#20|)) NIL)) - (RETURN NIL)) - (#2='T (HPUT |$bootDefined| |i| T))) - (SETQ |bfVar#20| (CDR |bfVar#20|)))) - (|defuse1| (APPEND |ndol| |e|) |b|))) + (SETQ |LETTMP#1| (|defSeparate| |a|)) + (SETQ |dol| (CAR |LETTMP#1|)) (SETQ |ndol| (CADR |LETTMP#1|)) + (LET ((|bfVar#20| |dol|) (|i| NIL)) + (LOOP + (COND + ((OR (ATOM |bfVar#20|) + (PROGN (SETQ |i| (CAR |bfVar#20|)) NIL)) + (RETURN NIL)) + (#2='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|)) #1#)) NIL) @@ -994,15 +975,12 @@ (RETURN (COND ((NULL |x|) (LIST NIL NIL)) - (#0='T - (PROGN - (SETQ |f| (CAR |x|)) - (SETQ |LETTMP#1| (|defSeparate| (CDR |x|))) - (SETQ |x1| (CAR |LETTMP#1|)) - (SETQ |x2| (CADR |LETTMP#1|)) - (COND - ((|bfBeginsDollar| |f|) (LIST (CONS |f| |x1|) |x2|)) - (#0# (LIST |x1| (CONS |f| |x2|)))))))))) + (#0='T (SETQ |f| (CAR |x|)) + (SETQ |LETTMP#1| (|defSeparate| (CDR |x|))) + (SETQ |x1| (CAR |LETTMP#1|)) (SETQ |x2| (CADR |LETTMP#1|)) + (COND + ((|bfBeginsDollar| |f|) (LIST (CONS |f| |x1|) |x2|)) + (#0# (LIST |x1| (CONS |f| |x2|))))))))) (DEFUN |unfluidlist| (|x|) (PROG (|y| |ISTMP#1|) @@ -1123,26 +1101,25 @@ (PROGN (SETQ |lines| (|shoeFindLines| |fn| |name| |a|)) (COND - (|lines| (PROGN - (SETQ |filename| + (|lines| (SETQ |filename| + (COND + ((< 8 (LENGTH |name|)) + (SUBSTRING |name| 0 8)) + ('T |name|))) + (SETQ |filename| + (CONCAT "/tmp/" |filename| ".boot")) + (|shoeOpenOutputFile| |stream| |filename| + (LET ((|bfVar#24| |lines|) (|line| NIL)) + (LOOP (COND - ((< 8 (LENGTH |name|)) - (SUBSTRING |name| 0 8)) - ('T |name|))) - (SETQ |filename| - (CONCAT "/tmp/" |filename| ".boot")) - (|shoeOpenOutputFile| |stream| |filename| - (LET ((|bfVar#24| |lines|) (|line| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#24|) - (PROGN - (SETQ |line| (CAR |bfVar#24|)) - NIL)) - (RETURN NIL)) - ('T (|shoeFileLine| |line| |stream|))) - (SETQ |bfVar#24| (CDR |bfVar#24|))))) - T)) + ((OR (ATOM |bfVar#24|) + (PROGN + (SETQ |line| (CAR |bfVar#24|)) + NIL)) + (RETURN NIL)) + ('T (|shoeFileLine| |line| |stream|))) + (SETQ |bfVar#24| (CDR |bfVar#24|))))) + T) ('T NIL)))))) (DEFUN |shoeTransform2| (|str|) @@ -1255,19 +1232,13 @@ (SETQ |a| (READ-LINE)) (COND ((EQL (LENGTH |a|) 0) - (PROGN - (WRITE-LINE "Boot Loop; to exit type ] ") - (BOOTLOOP))) - (#0='T - (PROGN - (SETQ |b| (|shoePrefix?| ")console" |a|)) - (COND - (|b| (PROGN - (SETQ |stream| *TERMINAL-IO*) - (PSTTOMC (|bRgen| |stream|)) - (BOOTLOOP))) - ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL) - (#0# (PROGN (PSTTOMC (LIST |a|)) (BOOTLOOP))))))))))) + (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTLOOP)) + (#0='T (SETQ |b| (|shoePrefix?| ")console" |a|)) + (COND + (|b| (SETQ |stream| *TERMINAL-IO*) + (PSTTOMC (|bRgen| |stream|)) (BOOTLOOP)) + ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL) + (#0# (PSTTOMC (LIST |a|)) (BOOTLOOP))))))))) (DEFUN BOOTPO () (PROG (|stream| |b| |a|) @@ -1276,17 +1247,13 @@ (SETQ |a| (READ-LINE)) (COND ((EQL (LENGTH |a|) 0) - (PROGN (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO))) - (#0='T - (PROGN - (SETQ |b| (|shoePrefix?| ")console" |a|)) - (COND - (|b| (PROGN - (SETQ |stream| *TERMINAL-IO*) - (PSTOUT (|bRgen| |stream|)) - (BOOTPO))) - ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL) - (#0# (PROGN (PSTOUT (LIST |a|)) (BOOTPO))))))))))) + (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO)) + (#0='T (SETQ |b| (|shoePrefix?| ")console" |a|)) + (COND + (|b| (SETQ |stream| *TERMINAL-IO*) + (PSTOUT (|bRgen| |stream|)) (BOOTPO)) + ((EQUAL (ELT |a| 0) (ELT "]" 0)) NIL) + (#0# (PSTOUT (LIST |a|)) (BOOTPO))))))))) (DEFUN PSTOUT (|string|) (PROG (|result| |callingPackage|) @@ -1334,12 +1301,10 @@ (COND ((NOT (EQL (|errorCount|) 0)) NIL) (|intFile| - (PROGN - (SETQ |objFile| - (|compileLispHandler| |progname| |options| - |intFile|)) - (DELETE-FILE |intFile|) - |objFile|)) + (SETQ |objFile| + (|compileLispHandler| |progname| |options| + |intFile|)) + (DELETE-FILE |intFile|) |objFile|) ('T NIL)))))) (EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) |