aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog8
-rw-r--r--src/boot/ast.boot55
-rw-r--r--src/boot/strap/ast.clisp5303
-rw-r--r--src/boot/strap/includer.clisp376
-rw-r--r--src/boot/strap/parser.clisp1294
-rw-r--r--src/boot/strap/pile.clisp158
-rw-r--r--src/boot/strap/scanner.clisp694
-rw-r--r--src/boot/strap/tokens.clisp435
-rw-r--r--src/boot/strap/translator.clisp1807
-rw-r--r--src/boot/strap/utility.clisp387
10 files changed, 5027 insertions, 5490 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index 35c60a2a..22dd7946 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,11 @@
+2011-09-29 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * boot/ast.boot (bfFor): Tidy. Handle hashtable iterator forms.
+ (bfIterateTable): New.
+ (separateIterators): Likewise.
+ (bfExpandTableIters): Likewise.
+ (bfLp1): Use them.
+
2011-09-20 Gabriel Dos Reis <gdr@cs.tamu.edu>
* algebra/annacat.spad.pamphlet: Remove.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 04a985ad..12749702 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -246,10 +246,11 @@ bfMakeCons l ==
a
['CONS,first l,bfMakeCons rest l]
-bfFor(bflhs,U,step) ==
- U is ["tails",:.] => bfForTree('ON, bflhs, second U)
- U is ["SEGMENT",:.] => bfSTEP(bflhs,second U,step,third U)
- bfForTree('IN, bflhs, U)
+bfFor(lhs,u,step) ==
+ u is ["tails",:.] => bfForTree('ON, lhs, second u)
+ u is ["SEGMENT",:.] => bfSTEP(lhs,second u,step,third u)
+ u is ['entries,:.] => bfIterateTable(lhs,second u)
+ bfForTree('IN,lhs,u)
bfForTree(OP,lhs,whole)==
whole :=
@@ -295,6 +296,9 @@ bfSTEP(id,fst,step,lst)==
suc := [['SETQ,id,["+",id,inc]]]
[[initvar,initval,suc,[],ex,[]]]
+++ Build a hashtable-iterator form.
+bfIterateTable(e,t) ==
+ ['%tbliter,e,t,gensym()]
bfINON x==
[op,id,whole] := x
@@ -423,8 +427,41 @@ bfDoCollect(expr,itl,adv,k) ==
extrait := [[[head,prev],['NIL,'NIL],nil,nil,nil,[head]]]
bfLp2(extrait,itl,body)
+++ Given the list of loop iterators, return 2-list where the first
+++ component is the list of all non-table iterators and the second
+++ is the list of all-table iterators,
+separateIterators iters ==
+ x := nil
+ y := nil
+ for iter in iters repeat
+ iter is ['%tbliter,:.] => y := [rest iter,:y]
+ x := [iter,:x]
+ [reverse! x,reverse! y]
+
+++ Expand the list of table iterators into a tuple form with
+++ (a) list of table iteration initialization
+++ (b) for each iteration, local bindings of key value
+++ (c) a list of exit conditions
+bfExpandTableIters iters ==
+ inits := nil
+ localBindings := nil
+ exits := nil
+ for [e,t,g] in iters repeat
+ inits := [[g,t],:inits]
+ x := gensym() -- exit guard
+ exits := [['NOT,x],:exits]
+ e is ['CONS,k,[CONS,v,'NIL]] and ident? k and ident? v =>
+ localBindings := [['MULTIPLE_-VALUE_-BIND,[x,k,v],[g]],:localBindings]
+ k := gensym() -- key local var
+ v := gensym() -- value local var
+ localBindings := [['MULTIPLE_-VALUE_-BIND,[x,k,v],[g],
+ bfLET1(['CONS,k,['CONS,v,'NIL]],e)],:localBindings]
+ [inits,localBindings,exits] -- NOTE: things are returned in reverse order.
+
bfLp1(iters,body)==
+ [iters,tbls] := separateIterators iters
[vars,inits,sucs,filters,exits,value] := bfSep bfAppend iters
+ [tblInits,tblLocs,tblExits] := bfExpandTableIters tbls
nbody :=
filters = nil => body
bfAND [:filters,body]
@@ -432,11 +469,15 @@ bfLp1(iters,body)==
value = nil => "NIL"
first value
exits :=
- exits = nil => nbody
- bfIf(bfOR exits,["RETURN",value],nbody)
+ exits = nil and tblExits = nil => nbody
+ bfIf(bfOR [:exits,:tblExits],["RETURN",value],nbody)
+ for locBinding in tblLocs repeat
+ exits := [:locBinding,exits]
loop := ["LOOP",exits,:sucs]
if vars then loop :=
- ["LET",[[v, i] for v in vars for i in inits], loop]
+ ["LET",[[v, i] for v in vars for i in inits],loop]
+ for x in tblInits repeat
+ loop := ['WITH_-HASH_-TABLE_-ITERATOR,x,loop]
loop
bfLp2(extrait,itl,body)==
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index a5faf9a0..71922a32 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -11,139 +11,125 @@
(DEFPARAMETER |$activeNamespace| NIL)
-(DEFUN |%Command| #0=(|bfVar#1|) (CONS '|%Command| (LIST . #0#)))
+(DEFUN |%Command| #1=(|bfVar#1|) (CONS '|%Command| (LIST . #1#)))
-(DEFUN |%Lisp| #0=(|bfVar#2|) (CONS '|%Lisp| (LIST . #0#)))
+(DEFUN |%Lisp| #1=(|bfVar#2|) (CONS '|%Lisp| (LIST . #1#)))
-(DEFUN |%Module| #0=(|bfVar#3| |bfVar#4| |bfVar#5|)
- (CONS '|%Module| (LIST . #0#)))
+(DEFUN |%Module| #1=(|bfVar#3| |bfVar#4| |bfVar#5|)
+ (CONS '|%Module| (LIST . #1#)))
-(DEFUN |%Namespace| #0=(|bfVar#6|) (CONS '|%Namespace| (LIST . #0#)))
+(DEFUN |%Namespace| #1=(|bfVar#6|) (CONS '|%Namespace| (LIST . #1#)))
-(DEFUN |%Import| #0=(|bfVar#7|) (CONS '|%Import| (LIST . #0#)))
+(DEFUN |%Import| #1=(|bfVar#7|) (CONS '|%Import| (LIST . #1#)))
-(DEFUN |%ImportSignature| #0=(|bfVar#8| |bfVar#9|)
- (CONS '|%ImportSignature| (LIST . #0#)))
+(DEFUN |%ImportSignature| #1=(|bfVar#8| |bfVar#9|)
+ (CONS '|%ImportSignature| (LIST . #1#)))
-(DEFUN |%TypeAlias| #0=(|bfVar#10| |bfVar#11|)
- (CONS '|%TypeAlias| (LIST . #0#)))
+(DEFUN |%TypeAlias| #1=(|bfVar#10| |bfVar#11|)
+ (CONS '|%TypeAlias| (LIST . #1#)))
-(DEFUN |%Signature| #0=(|bfVar#12| |bfVar#13|)
- (CONS '|%Signature| (LIST . #0#)))
+(DEFUN |%Signature| #1=(|bfVar#12| |bfVar#13|)
+ (CONS '|%Signature| (LIST . #1#)))
-(DEFUN |%Mapping| #0=(|bfVar#14| |bfVar#15|)
- (CONS '|%Mapping| (LIST . #0#)))
+(DEFUN |%Mapping| #1=(|bfVar#14| |bfVar#15|) (CONS '|%Mapping| (LIST . #1#)))
-(DEFUN |%Forall| #0=(|bfVar#16| |bfVar#17|)
- (CONS '|%Forall| (LIST . #0#)))
+(DEFUN |%Forall| #1=(|bfVar#16| |bfVar#17|) (CONS '|%Forall| (LIST . #1#)))
-(DEFUN |%SuffixDot| #0=(|bfVar#18|) (CONS '|%SuffixDot| (LIST . #0#)))
+(DEFUN |%SuffixDot| #1=(|bfVar#18|) (CONS '|%SuffixDot| (LIST . #1#)))
-(DEFUN |%Quote| #0=(|bfVar#19|) (CONS '|%Quote| (LIST . #0#)))
+(DEFUN |%Quote| #1=(|bfVar#19|) (CONS '|%Quote| (LIST . #1#)))
-(DEFUN |%EqualPattern| #0=(|bfVar#20|)
- (CONS '|%EqualPattern| (LIST . #0#)))
+(DEFUN |%EqualPattern| #1=(|bfVar#20|) (CONS '|%EqualPattern| (LIST . #1#)))
-(DEFUN |%Colon| #0=(|bfVar#21|) (CONS '|%Colon| (LIST . #0#)))
+(DEFUN |%Colon| #1=(|bfVar#21|) (CONS '|%Colon| (LIST . #1#)))
-(DEFUN |%QualifiedName| #0=(|bfVar#22| |bfVar#23|)
- (CONS '|%QualifiedName| (LIST . #0#)))
+(DEFUN |%QualifiedName| #1=(|bfVar#22| |bfVar#23|)
+ (CONS '|%QualifiedName| (LIST . #1#)))
-(DEFUN |%DefaultValue| #0=(|bfVar#24| |bfVar#25|)
- (CONS '|%DefaultValue| (LIST . #0#)))
+(DEFUN |%DefaultValue| #1=(|bfVar#24| |bfVar#25|)
+ (CONS '|%DefaultValue| (LIST . #1#)))
-(DEFUN |%Bracket| #0=(|bfVar#26|) (CONS '|%Bracket| (LIST . #0#)))
+(DEFUN |%Bracket| #1=(|bfVar#26|) (CONS '|%Bracket| (LIST . #1#)))
-(DEFUN |%UnboundedSegment| #0=(|bfVar#27|)
- (CONS '|%UnboundedSegment| (LIST . #0#)))
+(DEFUN |%UnboundedSegment| #1=(|bfVar#27|)
+ (CONS '|%UnboundedSegment| (LIST . #1#)))
-(DEFUN |%BoundedSgement| #0=(|bfVar#28| |bfVar#29|)
- (CONS '|%BoundedSgement| (LIST . #0#)))
+(DEFUN |%BoundedSgement| #1=(|bfVar#28| |bfVar#29|)
+ (CONS '|%BoundedSgement| (LIST . #1#)))
-(DEFUN |%Tuple| #0=(|bfVar#30|) (CONS '|%Tuple| (LIST . #0#)))
+(DEFUN |%Tuple| #1=(|bfVar#30|) (CONS '|%Tuple| (LIST . #1#)))
-(DEFUN |%ColonAppend| #0=(|bfVar#31| |bfVar#32|)
- (CONS '|%ColonAppend| (LIST . #0#)))
+(DEFUN |%ColonAppend| #1=(|bfVar#31| |bfVar#32|)
+ (CONS '|%ColonAppend| (LIST . #1#)))
-(DEFUN |%Pretend| #0=(|bfVar#33| |bfVar#34|)
- (CONS '|%Pretend| (LIST . #0#)))
+(DEFUN |%Pretend| #1=(|bfVar#33| |bfVar#34|) (CONS '|%Pretend| (LIST . #1#)))
-(DEFUN |%Is| #0=(|bfVar#35| |bfVar#36|) (CONS '|%Is| (LIST . #0#)))
+(DEFUN |%Is| #1=(|bfVar#35| |bfVar#36|) (CONS '|%Is| (LIST . #1#)))
-(DEFUN |%Isnt| #0=(|bfVar#37| |bfVar#38|)
- (CONS '|%Isnt| (LIST . #0#)))
+(DEFUN |%Isnt| #1=(|bfVar#37| |bfVar#38|) (CONS '|%Isnt| (LIST . #1#)))
-(DEFUN |%Reduce| #0=(|bfVar#39| |bfVar#40|)
- (CONS '|%Reduce| (LIST . #0#)))
+(DEFUN |%Reduce| #1=(|bfVar#39| |bfVar#40|) (CONS '|%Reduce| (LIST . #1#)))
-(DEFUN |%PrefixExpr| #0=(|bfVar#41| |bfVar#42|)
- (CONS '|%PrefixExpr| (LIST . #0#)))
+(DEFUN |%PrefixExpr| #1=(|bfVar#41| |bfVar#42|)
+ (CONS '|%PrefixExpr| (LIST . #1#)))
-(DEFUN |%Call| #0=(|bfVar#43| |bfVar#44|)
- (CONS '|%Call| (LIST . #0#)))
+(DEFUN |%Call| #1=(|bfVar#43| |bfVar#44|) (CONS '|%Call| (LIST . #1#)))
-(DEFUN |%InfixExpr| #0=(|bfVar#45| |bfVar#46| |bfVar#47|)
- (CONS '|%InfixExpr| (LIST . #0#)))
+(DEFUN |%InfixExpr| #1=(|bfVar#45| |bfVar#46| |bfVar#47|)
+ (CONS '|%InfixExpr| (LIST . #1#)))
-(DEFUN |%ConstantDefinition| #0=(|bfVar#48| |bfVar#49|)
- (CONS '|%ConstantDefinition| (LIST . #0#)))
+(DEFUN |%ConstantDefinition| #1=(|bfVar#48| |bfVar#49|)
+ (CONS '|%ConstantDefinition| (LIST . #1#)))
-(DEFUN |%Definition| #0=(|bfVar#50| |bfVar#51| |bfVar#52|)
- (CONS '|%Definition| (LIST . #0#)))
+(DEFUN |%Definition| #1=(|bfVar#50| |bfVar#51| |bfVar#52|)
+ (CONS '|%Definition| (LIST . #1#)))
-(DEFUN |%Macro| #0=(|bfVar#53| |bfVar#54| |bfVar#55|)
- (CONS '|%Macro| (LIST . #0#)))
+(DEFUN |%Macro| #1=(|bfVar#53| |bfVar#54| |bfVar#55|)
+ (CONS '|%Macro| (LIST . #1#)))
-(DEFUN |%Lambda| #0=(|bfVar#56| |bfVar#57|)
- (CONS '|%Lambda| (LIST . #0#)))
+(DEFUN |%Lambda| #1=(|bfVar#56| |bfVar#57|) (CONS '|%Lambda| (LIST . #1#)))
-(DEFUN |%SuchThat| #0=(|bfVar#58|) (CONS '|%SuchThat| (LIST . #0#)))
+(DEFUN |%SuchThat| #1=(|bfVar#58|) (CONS '|%SuchThat| (LIST . #1#)))
-(DEFUN |%Assignment| #0=(|bfVar#59| |bfVar#60|)
- (CONS '|%Assignment| (LIST . #0#)))
+(DEFUN |%Assignment| #1=(|bfVar#59| |bfVar#60|)
+ (CONS '|%Assignment| (LIST . #1#)))
-(DEFUN |%While| #0=(|bfVar#61|) (CONS '|%While| (LIST . #0#)))
+(DEFUN |%While| #1=(|bfVar#61|) (CONS '|%While| (LIST . #1#)))
-(DEFUN |%Until| #0=(|bfVar#62|) (CONS '|%Until| (LIST . #0#)))
+(DEFUN |%Until| #1=(|bfVar#62|) (CONS '|%Until| (LIST . #1#)))
-(DEFUN |%For| #0=(|bfVar#63| |bfVar#64| |bfVar#65|)
- (CONS '|%For| (LIST . #0#)))
+(DEFUN |%For| #1=(|bfVar#63| |bfVar#64| |bfVar#65|) (CONS '|%For| (LIST . #1#)))
-(DEFUN |%Implies| #0=(|bfVar#66| |bfVar#67|)
- (CONS '|%Implies| (LIST . #0#)))
+(DEFUN |%Implies| #1=(|bfVar#66| |bfVar#67|) (CONS '|%Implies| (LIST . #1#)))
-(DEFUN |%Iterators| #0=(|bfVar#68|) (CONS '|%Iterators| (LIST . #0#)))
+(DEFUN |%Iterators| #1=(|bfVar#68|) (CONS '|%Iterators| (LIST . #1#)))
-(DEFUN |%Cross| #0=(|bfVar#69|) (CONS '|%Cross| (LIST . #0#)))
+(DEFUN |%Cross| #1=(|bfVar#69|) (CONS '|%Cross| (LIST . #1#)))
-(DEFUN |%Repeat| #0=(|bfVar#70| |bfVar#71|)
- (CONS '|%Repeat| (LIST . #0#)))
+(DEFUN |%Repeat| #1=(|bfVar#70| |bfVar#71|) (CONS '|%Repeat| (LIST . #1#)))
-(DEFUN |%Pile| #0=(|bfVar#72|) (CONS '|%Pile| (LIST . #0#)))
+(DEFUN |%Pile| #1=(|bfVar#72|) (CONS '|%Pile| (LIST . #1#)))
-(DEFUN |%Append| #0=(|bfVar#73|) (CONS '|%Append| (LIST . #0#)))
+(DEFUN |%Append| #1=(|bfVar#73|) (CONS '|%Append| (LIST . #1#)))
-(DEFUN |%Case| #0=(|bfVar#74| |bfVar#75|)
- (CONS '|%Case| (LIST . #0#)))
+(DEFUN |%Case| #1=(|bfVar#74| |bfVar#75|) (CONS '|%Case| (LIST . #1#)))
-(DEFUN |%Return| #0=(|bfVar#76|) (CONS '|%Return| (LIST . #0#)))
+(DEFUN |%Return| #1=(|bfVar#76|) (CONS '|%Return| (LIST . #1#)))
-(DEFUN |%Leave| #0=(|bfVar#77|) (CONS '|%Leave| (LIST . #0#)))
+(DEFUN |%Leave| #1=(|bfVar#77|) (CONS '|%Leave| (LIST . #1#)))
-(DEFUN |%Throw| #0=(|bfVar#78|) (CONS '|%Throw| (LIST . #0#)))
+(DEFUN |%Throw| #1=(|bfVar#78|) (CONS '|%Throw| (LIST . #1#)))
-(DEFUN |%Catch| #0=(|bfVar#79| |bfVar#80|)
- (CONS '|%Catch| (LIST . #0#)))
+(DEFUN |%Catch| #1=(|bfVar#79| |bfVar#80|) (CONS '|%Catch| (LIST . #1#)))
-(DEFUN |%Finally| #0=(|bfVar#81|) (CONS '|%Finally| (LIST . #0#)))
+(DEFUN |%Finally| #1=(|bfVar#81|) (CONS '|%Finally| (LIST . #1#)))
-(DEFUN |%Try| #0=(|bfVar#82| |bfVar#83|) (CONS '|%Try| (LIST . #0#)))
+(DEFUN |%Try| #1=(|bfVar#82| |bfVar#83|) (CONS '|%Try| (LIST . #1#)))
-(DEFUN |%Where| #0=(|bfVar#84| |bfVar#85|)
- (CONS '|%Where| (LIST . #0#)))
+(DEFUN |%Where| #1=(|bfVar#84| |bfVar#85|) (CONS '|%Where| (LIST . #1#)))
-(DEFUN |%Structure| #0=(|bfVar#86| |bfVar#87|)
- (CONS '|%Structure| (LIST . #0#)))
+(DEFUN |%Structure| #1=(|bfVar#86| |bfVar#87|)
+ (CONS '|%Structure| (LIST . #1#)))
(DEFPARAMETER |$inDefIS| NIL)
@@ -154,38 +140,36 @@
(DEFUN |bfGenSymbol| ()
(DECLARE (SPECIAL |$GenVarCounter|))
(PROGN
- (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1))
- (INTERN (CONCAT "bfVar#" (WRITE-TO-STRING |$GenVarCounter|)))))
+ (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1))
+ (INTERN (CONCAT "bfVar#" (WRITE-TO-STRING |$GenVarCounter|)))))
(DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfLetVar|))
(DEFUN |bfLetVar| ()
(DECLARE (SPECIAL |$letGenVarCounter|))
(PROGN
- (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1))
- (INTERN (CONCAT "LETTMP#" (WRITE-TO-STRING |$letGenVarCounter|)))))
+ (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1))
+ (INTERN (CONCAT "LETTMP#" (WRITE-TO-STRING |$letGenVarCounter|)))))
(DECLAIM (FTYPE (FUNCTION NIL |%Symbol|) |bfIsVar|))
(DEFUN |bfIsVar| ()
(DECLARE (SPECIAL |$isGenVarCounter|))
(PROGN
- (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1))
- (INTERN (CONCAT "ISTMP#" (WRITE-TO-STRING |$isGenVarCounter|)))))
+ (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1))
+ (INTERN (CONCAT "ISTMP#" (WRITE-TO-STRING |$isGenVarCounter|)))))
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfColon|))
(DEFUN |bfColon| (|x|) (LIST 'COLON |x|))
-(DECLAIM (FTYPE (FUNCTION (|%Symbol| |%Symbol|) |%Symbol|)
- |bfColonColon|))
+(DECLAIM (FTYPE (FUNCTION (|%Symbol| |%Symbol|) |%Symbol|) |bfColonColon|))
(DEFUN |bfColonColon| (|package| |name|)
(COND
- ((AND (|%hasFeature| :CLISP)
- (|symbolMember?| |package| '(EXT FFI)))
- (FIND-SYMBOL (SYMBOL-NAME |name|) |package|))
- (T (INTERN (SYMBOL-NAME |name|) |package|))))
+ ((AND (|%hasFeature| :CLISP) (|symbolMember?| |package| '(EXT FFI)))
+ (FIND-SYMBOL (SYMBOL-NAME |name|) |package|))
+ (T (INTERN (SYMBOL-NAME |name|) |package|))))
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |bfSymbol|))
@@ -207,70 +191,60 @@
(DEFUN |bfBracket| (|part|) |part|)
-(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|)) (|%List| |%Form|))
- |bfPile|))
+(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|)) (|%List| |%Form|)) |bfPile|))
(DEFUN |bfPile| (|part|) |part|)
(DEFUN |bfDo| (|x|) |x|)
-(DEFUN |bfAtScope| (|s| |x|)
- (LIST 'LET (LIST (LIST '*PACKAGE* |s|)) |x|))
+(DEFUN |bfAtScope| (|s| |x|) (LIST 'LET (LIST (LIST '*PACKAGE* |s|)) |x|))
-(DECLAIM (FTYPE (FUNCTION ((|%List| (|%List| |%Form|)))
- (|%List| |%Form|))
- |bfAppend|))
+(DECLAIM
+ (FTYPE (FUNCTION ((|%List| (|%List| |%Form|))) (|%List| |%Form|)) |bfAppend|))
(DEFUN |bfAppend| (|ls|)
(PROG (|p| |r| |l|)
(RETURN
- (COND
- ((NOT (AND (CONSP |ls|)
- (PROGN
- (SETQ |l| (CAR |ls|))
- (SETQ |ls| (CDR |ls|))
- T)))
- NIL)
- (T (SETQ |r| (|copyList| |l|)) (SETQ |p| |r|)
- (LOOP
- (COND
- ((NOT (AND (CONSP |ls|)
- (PROGN
- (SETQ |l| (CAR |ls|))
- (SETQ |ls| (CDR |ls|))
- T)))
- (RETURN |r|))
- ((NULL |l|) NIL)
- (T (RPLACD (|lastNode| |p|) (|copyList| |l|))
- (SETQ |p| (CDR |p|))))))))))
+ (COND
+ ((NOT
+ (AND (CONSP |ls|)
+ (PROGN (SETQ |l| (CAR |ls|)) (SETQ |ls| (CDR |ls|)) T)))
+ NIL)
+ (T (SETQ |r| (|copyList| |l|)) (SETQ |p| |r|)
+ (LOOP
+ (COND
+ ((NOT
+ (AND (CONSP |ls|)
+ (PROGN (SETQ |l| (CAR |ls|)) (SETQ |ls| (CDR |ls|)) T)))
+ (RETURN |r|))
+ ((NULL |l|) NIL)
+ (T (RPLACD (|lastNode| |p|) (|copyList| |l|))
+ (SETQ |p| (CDR |p|))))))))))
-(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|) |%Form|) |%Form|)
- |bfColonAppend|))
+(DECLAIM (FTYPE (FUNCTION ((|%List| |%Form|) |%Form|) |%Form|) |bfColonAppend|))
(DEFUN |bfColonAppend| (|x| |y|)
(PROG (|a|)
(RETURN
- (COND
- ((NULL |x|)
- (COND
- ((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|)))))))
+ (COND
+ ((NULL |x|)
+ (COND
+ ((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|)))))))
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |bfBeginsDollar|))
-(DEFUN |bfBeginsDollar| (|x|)
- (CHAR= (SCHAR (SYMBOL-NAME |x|) 0) (|char| '$)))
+(DEFUN |bfBeginsDollar| (|x|) (CHAR= (SCHAR (SYMBOL-NAME |x|) 0) (|char| '$)))
(DEFUN |compFluid| (|id|) (LIST 'FLUID |id|))
(DEFUN |compFluidize| (|x|)
- (COND
- ((NULL |x|) NIL)
- ((AND (SYMBOLP |x|) (|bfBeginsDollar| |x|)) (|compFluid| |x|))
- ((|atomic?| |x|) |x|)
- (T (CONS (|compFluidize| (CAR |x|)) (|compFluidize| (CDR |x|))))))
+ (COND ((NULL |x|) NIL)
+ ((AND (SYMBOLP |x|) (|bfBeginsDollar| |x|)) (|compFluid| |x|))
+ ((|atomic?| |x|) |x|)
+ (T (CONS (|compFluidize| (CAR |x|)) (|compFluidize| (CDR |x|))))))
(DEFUN |bfPlace| (|x|) (CONS '|%Place| |x|))
@@ -278,179 +252,167 @@
(DEFUN |bfTupleP| (|x|) (AND (CONSP |x|) (EQ (CAR |x|) 'TUPLE)))
-(DEFUN |bfUntuple| (|bf|)
- (COND ((|bfTupleP| |bf|) (CDR |bf|)) (T |bf|)))
+(DEFUN |bfUntuple| (|bf|) (COND ((|bfTupleP| |bf|) (CDR |bf|)) (T |bf|)))
-(DEFUN |bfTupleIf| (|x|)
- (COND ((|bfTupleP| |x|) |x|) (T (|bfTuple| |x|))))
+(DEFUN |bfTupleIf| (|x|) (COND ((|bfTupleP| |x|) |x|) (T (|bfTuple| |x|))))
(DEFUN |bfTupleConstruct| (|b|)
(PROG (|ISTMP#1| |a|)
(RETURN
- (PROGN
- (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) (T (LIST |b|))))
- (COND
- ((LET ((|bfVar#2| NIL) (|bfVar#1| |a|) (|x| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- (T (SETQ |bfVar#2|
- (AND (CONSP |x|) (EQ (CAR |x|) 'COLON)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (NULL (CDR |ISTMP#1|))))))
- (COND (|bfVar#2| (RETURN |bfVar#2|)))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (|bfMakeCons| |a|))
- (T (CONS 'LIST |a|)))))))
+ (PROGN
+ (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) (T (LIST |b|))))
+ (COND
+ ((LET ((|bfVar#2| NIL) (|bfVar#1| |a|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T
+ (SETQ |bfVar#2|
+ (AND (CONSP |x|) (EQ (CAR |x|) 'COLON)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))))
+ (COND (|bfVar#2| (RETURN |bfVar#2|)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (|bfMakeCons| |a|))
+ (T (CONS 'LIST |a|)))))))
(DEFUN |bfConstruct| (|b|)
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) (T (LIST |b|))))
- (|bfMakeCons| |a|)))))
+ (PROGN
+ (SETQ |a| (COND ((|bfTupleP| |b|) (CDR |b|)) (T (LIST |b|))))
+ (|bfMakeCons| |a|)))))
(DEFUN |bfMakeCons| (|l|)
(PROG (|l1| |a| |ISTMP#2| |ISTMP#1|)
(RETURN
- (COND
- ((NULL |l|) NIL)
- ((AND (CONSP |l|)
- (PROGN
- (SETQ |ISTMP#1| (CAR |l|))
- (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'COLON)
- (PROGN
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (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|))))))))
-
-(DEFUN |bfFor| (|bflhs| U |step|)
+ (COND ((NULL |l|) NIL)
+ ((AND (CONSP |l|)
+ (PROGN
+ (SETQ |ISTMP#1| (CAR |l|))
+ (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'COLON)
+ (PROGN
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (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|))))))))
+
+(DEFUN |bfFor| (|lhs| |u| |step|)
(COND
- ((AND (CONSP U) (EQ (CAR U) '|tails|))
- (|bfForTree| 'ON |bflhs| (CADR U)))
- ((AND (CONSP U) (EQ (CAR U) 'SEGMENT))
- (|bfSTEP| |bflhs| (CADR U) |step| (CADDR U)))
- (T (|bfForTree| 'IN |bflhs| U))))
+ ((AND (CONSP |u|) (EQ (CAR |u|) '|tails|))
+ (|bfForTree| 'ON |lhs| (CADR |u|)))
+ ((AND (CONSP |u|) (EQ (CAR |u|) 'SEGMENT))
+ (|bfSTEP| |lhs| (CADR |u|) |step| (CADDR |u|)))
+ ((AND (CONSP |u|) (EQ (CAR |u|) '|entries|))
+ (|bfIterateTable| |lhs| (CADR |u|)))
+ (T (|bfForTree| 'IN |lhs| |u|))))
(DEFUN |bfForTree| (OP |lhs| |whole|)
(PROG (G)
(RETURN
- (PROGN
- (SETQ |whole|
- (COND
- ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|)))
- (T |whole|)))
- (COND
- ((NOT (CONSP |lhs|)) (|bfINON| (LIST OP |lhs| |whole|)))
- (T (SETQ |lhs|
- (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) (T |lhs|)))
+ (PROGN
+ (SETQ |whole|
+ (COND ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|)))
+ (T |whole|)))
+ (COND ((NOT (CONSP |lhs|)) (|bfINON| (LIST OP |lhs| |whole|)))
+ (T (SETQ |lhs| (COND ((|bfTupleP| |lhs|) (CADR |lhs|)) (T |lhs|)))
(COND
- ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T))
- (SETQ G (CADR |lhs|))
- (|append| (|bfINON| (LIST OP G |whole|))
- (|bfSuchthat| (|bfIS| G (CADDR |lhs|)))))
- (T (SETQ G (|bfGenSymbol|))
- (|append| (|bfINON| (LIST OP G |whole|))
- (|bfSuchthat| (|bfIS| G |lhs|)))))))))))
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T)) (SETQ G (CADR |lhs|))
+ (|append| (|bfINON| (LIST OP G |whole|))
+ (|bfSuchthat| (|bfIS| G (CADDR |lhs|)))))
+ (T (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|)
(RETURN
- (PROGN
- (COND ((EQ |id| 'DOT) (SETQ |id| (|bfGenSymbol|))))
- (SETQ |initvar| (LIST |id|))
- (SETQ |initval| (LIST |fst|))
- (SETQ |inc|
- (COND
- ((NOT (CONSP |step|)) |step|)
- (T (SETQ |g1| (|bfGenSymbol|))
- (SETQ |initvar| (CONS |g1| |initvar|))
- (SETQ |initval| (CONS |step| |initval|)) |g1|)))
- (SETQ |final|
- (COND
- ((NOT (CONSP |lst|)) |lst|)
- (T (SETQ |g2| (|bfGenSymbol|))
- (SETQ |initvar| (CONS |g2| |initvar|))
- (SETQ |initval| (CONS |lst| |initval|)) |g2|)))
- (SETQ |ex|
- (COND
- ((NULL |lst|) NIL)
- ((INTEGERP |inc|)
- (SETQ |pred| (COND ((MINUSP |inc|) '<) (T '>)))
- (LIST (LIST |pred| |id| |final|)))
- (T (LIST (LIST 'COND
- (LIST (LIST 'MINUSP |inc|)
- (LIST '< |id| |final|))
- (LIST 'T (LIST '> |id| |final|)))))))
- (SETQ |suc| (LIST (LIST 'SETQ |id| (LIST '+ |id| |inc|))))
- (LIST (LIST |initvar| |initval| |suc| NIL |ex| NIL))))))
+ (PROGN
+ (COND ((EQ |id| 'DOT) (SETQ |id| (|bfGenSymbol|))))
+ (SETQ |initvar| (LIST |id|))
+ (SETQ |initval| (LIST |fst|))
+ (SETQ |inc|
+ (COND ((NOT (CONSP |step|)) |step|)
+ (T (SETQ |g1| (|bfGenSymbol|))
+ (SETQ |initvar| (CONS |g1| |initvar|))
+ (SETQ |initval| (CONS |step| |initval|)) |g1|)))
+ (SETQ |final|
+ (COND ((NOT (CONSP |lst|)) |lst|)
+ (T (SETQ |g2| (|bfGenSymbol|))
+ (SETQ |initvar| (CONS |g2| |initvar|))
+ (SETQ |initval| (CONS |lst| |initval|)) |g2|)))
+ (SETQ |ex|
+ (COND ((NULL |lst|) NIL)
+ ((INTEGERP |inc|)
+ (SETQ |pred| (COND ((MINUSP |inc|) '<) (T '>)))
+ (LIST (LIST |pred| |id| |final|)))
+ (T
+ (LIST
+ (LIST 'COND
+ (LIST (LIST 'MINUSP |inc|) (LIST '< |id| |final|))
+ (LIST 'T (LIST '> |id| |final|)))))))
+ (SETQ |suc| (LIST (LIST 'SETQ |id| (LIST '+ |id| |inc|))))
+ (LIST (LIST |initvar| |initval| |suc| NIL |ex| NIL))))))
+
+(DEFUN |bfIterateTable| (|e| |t|) (LIST '|%tbliter| |e| |t| (GENSYM)))
(DEFUN |bfINON| (|x|)
(PROG (|whole| |id| |op|)
(RETURN
- (PROGN
- (SETQ |op| (CAR |x|))
- (SETQ |id| (CADR . #0=(|x|)))
- (SETQ |whole| (CADDR . #0#))
- (COND
- ((EQ |op| 'ON) (|bfON| |id| |whole|))
- (T (|bfIN| |id| |whole|)))))))
+ (PROGN
+ (SETQ |op| (CAR |x|))
+ (SETQ |id| (CADR . #1=(|x|)))
+ (SETQ |whole| (CADDR . #1#))
+ (COND ((EQ |op| 'ON) (|bfON| |id| |whole|)) (T (|bfIN| |id| |whole|)))))))
(DEFUN |bfIN| (|x| E)
(PROG (|exitCond| |inits| |vars| |g|)
(RETURN
- (PROGN
- (SETQ |g| (|bfGenSymbol|))
- (SETQ |vars| (LIST |g|))
- (SETQ |inits| (LIST E))
- (SETQ |exitCond| (LIST 'NOT (LIST 'CONSP |g|)))
- (COND
- ((NOT (EQ |x| 'DOT))
- (SETQ |vars| (|append| |vars| (CONS |x| NIL)))
- (SETQ |inits| (|append| |inits| (CONS NIL NIL)))
- (SETQ |exitCond|
- (LIST 'OR |exitCond|
- (LIST 'PROGN (LIST 'SETQ |x| (LIST 'CAR |g|))
- 'NIL)))))
- (LIST (LIST |vars| |inits|
- (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL
- (LIST |exitCond|) NIL))))))
+ (PROGN
+ (SETQ |g| (|bfGenSymbol|))
+ (SETQ |vars| (LIST |g|))
+ (SETQ |inits| (LIST E))
+ (SETQ |exitCond| (LIST 'NOT (LIST 'CONSP |g|)))
+ (COND
+ ((NOT (EQ |x| 'DOT)) (SETQ |vars| (|append| |vars| (CONS |x| NIL)))
+ (SETQ |inits| (|append| |inits| (CONS NIL NIL)))
+ (SETQ |exitCond|
+ (LIST 'OR |exitCond|
+ (LIST 'PROGN (LIST 'SETQ |x| (LIST 'CAR |g|)) 'NIL)))))
+ (LIST
+ (LIST |vars| |inits| (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL
+ (LIST |exitCond|) NIL))))))
(DEFUN |bfON| (|x| E)
(PROG (|var| |init|)
(RETURN
- (PROGN
- (COND ((EQ |x| 'DOT) (SETQ |x| (|bfGenSymbol|))))
- (SETQ |var| (SETQ |init| NIL))
- (COND
- ((OR (NOT (SYMBOLP E)) (NOT (EQ |x| E)))
- (SETQ |var| (LIST |x|)) (SETQ |init| (LIST E))))
- (LIST (LIST |var| |init|
- (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL
- (LIST (LIST 'NOT (LIST 'CONSP |x|))) NIL))))))
+ (PROGN
+ (COND ((EQ |x| 'DOT) (SETQ |x| (|bfGenSymbol|))))
+ (SETQ |var| (SETQ |init| NIL))
+ (COND
+ ((OR (NOT (SYMBOLP E)) (NOT (EQ |x| E))) (SETQ |var| (LIST |x|))
+ (SETQ |init| (LIST E))))
+ (LIST
+ (LIST |var| |init| (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL
+ (LIST (LIST 'NOT (LIST 'CONSP |x|))) NIL))))))
-(DEFUN |bfSuchthat| (|p|)
- (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL)))
+(DEFUN |bfSuchthat| (|p|) (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL)))
-(DEFUN |bfWhile| (|p|)
- (LIST (LIST NIL NIL NIL NIL (LIST (|bfNOT| |p|)) NIL)))
+(DEFUN |bfWhile| (|p|) (LIST (LIST NIL NIL NIL NIL (LIST (|bfNOT| |p|)) NIL)))
(DEFUN |bfUntil| (|p|)
(PROG (|g|)
(RETURN
- (PROGN
- (SETQ |g| (|bfGenSymbol|))
- (LIST (LIST (LIST |g|) (LIST NIL) (LIST (LIST 'SETQ |g| |p|))
- NIL (LIST |g|) NIL))))))
+ (PROGN
+ (SETQ |g| (|bfGenSymbol|))
+ (LIST
+ (LIST (LIST |g|) (LIST NIL) (LIST (LIST 'SETQ |g| |p|)) NIL (LIST |g|)
+ NIL))))))
(DEFUN |bfIterators| (|x|) (CONS 'ITERATORS |x|))
@@ -458,93 +420,90 @@
(DEFUN |bfLp| (|iters| |body|)
(COND
- ((AND (CONSP |iters|) (EQ (CAR |iters|) 'ITERATORS))
- (|bfLp1| (CDR |iters|) |body|))
- (T (|bfLpCross| (CDR |iters|) |body|))))
+ ((AND (CONSP |iters|) (EQ (CAR |iters|) 'ITERATORS))
+ (|bfLp1| (CDR |iters|) |body|))
+ (T (|bfLpCross| (CDR |iters|) |body|))))
(DEFUN |bfLpCross| (|iters| |body|)
- (COND
- ((NULL (CDR |iters|)) (|bfLp| (CAR |iters|) |body|))
- (T (|bfLp| (CAR |iters|) (|bfLpCross| (CDR |iters|) |body|)))))
+ (COND ((NULL (CDR |iters|)) (|bfLp| (CAR |iters|) |body|))
+ (T (|bfLp| (CAR |iters|) (|bfLpCross| (CDR |iters|) |body|)))))
(DEFUN |bfSep| (|iters|)
(PROG (|r| |f|)
(RETURN
- (COND
- ((NULL |iters|) (LIST NIL NIL NIL NIL NIL NIL))
- (T (SETQ |f| (CAR |iters|)) (SETQ |r| (|bfSep| (CDR |iters|)))
- (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) (|bfVar#1| |f|)
- (|i| NIL) (|bfVar#2| |r|) (|j| NIL))
- (LOOP
+ (COND ((NULL |iters|) (LIST NIL NIL NIL NIL NIL NIL))
+ (T (SETQ |f| (CAR |iters|)) (SETQ |r| (|bfSep| (CDR |iters|)))
+ (LET ((|bfVar#3| NIL)
+ (|bfVar#4| NIL)
+ (|bfVar#1| |f|)
+ (|i| NIL)
+ (|bfVar#2| |r|)
+ (|j| NIL))
+ (LOOP
(COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)
- (NOT (CONSP |bfVar#2|))
- (PROGN (SETQ |j| (CAR |bfVar#2|)) NIL))
- (RETURN |bfVar#3|))
- ((NULL |bfVar#3|)
- (SETQ |bfVar#3| #0=(CONS (|append| |i| |j|) NIL))
- (SETQ |bfVar#4| |bfVar#3|))
- (T (RPLACD |bfVar#4| #0#)
- (SETQ |bfVar#4| (CDR |bfVar#4|))))
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)
+ (NOT (CONSP |bfVar#2|))
+ (PROGN (SETQ |j| (CAR |bfVar#2|)) NIL))
+ (RETURN |bfVar#3|))
+ ((NULL |bfVar#3|)
+ (SETQ |bfVar#3| #1=(CONS (|append| |i| |j|) NIL))
+ (SETQ |bfVar#4| |bfVar#3|))
+ (T (RPLACD |bfVar#4| #1#) (SETQ |bfVar#4| (CDR |bfVar#4|))))
(SETQ |bfVar#1| (CDR |bfVar#1|))
(SETQ |bfVar#2| (CDR |bfVar#2|)))))))))
(DEFUN |bfReduce| (|op| |y|)
(PROG (|it| |ny| |g2| |body| |g1| |g| |init| |a|)
(RETURN
- (PROGN
- (SETQ |a|
- (COND
- ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) (CADR |op|))
- (T |op|)))
- (SETQ |op| (|bfReName| |a|))
- (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA)))
- (SETQ |g| (|bfGenSymbol|))
- (SETQ |g1| (|bfGenSymbol|))
- (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g| |g1|)))
- (COND
- ((NULL |init|) (SETQ |g2| (|bfGenSymbol|))
- (SETQ |init| (LIST 'CAR |g2|)) (SETQ |ny| (LIST 'CDR |g2|))
- (SETQ |it|
- (CONS 'ITERATORS
- (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL
- NIL NIL (LIST |g|)))
- (|bfIN| |g1| |ny|))))
- (|bfMKPROGN|
- (LIST (LIST 'L%T |g2| |y|) (|bfLp| |it| |body|))))
- (T (SETQ |init| (CAR |init|))
- (SETQ |it|
- (CONS 'ITERATORS
- (LIST (LIST (LIST (LIST |g|) (LIST |init|) NIL
- NIL NIL (LIST |g|)))
- (|bfIN| |g1| |y|))))
- (|bfLp| |it| |body|)))))))
+ (PROGN
+ (SETQ |a|
+ (COND ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) (CADR |op|))
+ (T |op|)))
+ (SETQ |op| (|bfReName| |a|))
+ (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA)))
+ (SETQ |g| (|bfGenSymbol|))
+ (SETQ |g1| (|bfGenSymbol|))
+ (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g| |g1|)))
+ (COND
+ ((NULL |init|) (SETQ |g2| (|bfGenSymbol|))
+ (SETQ |init| (LIST 'CAR |g2|)) (SETQ |ny| (LIST 'CDR |g2|))
+ (SETQ |it|
+ (CONS 'ITERATORS
+ (LIST
+ (LIST
+ (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|)))
+ (|bfIN| |g1| |ny|))))
+ (|bfMKPROGN| (LIST (LIST 'L%T |g2| |y|) (|bfLp| |it| |body|))))
+ (T (SETQ |init| (CAR |init|))
+ (SETQ |it|
+ (CONS 'ITERATORS
+ (LIST
+ (LIST
+ (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|)))
+ (|bfIN| |g1| |y|))))
+ (|bfLp| |it| |body|)))))))
(DEFUN |bfReduceCollect| (|op| |y|)
(PROG (|seq| |init| |a| |itl| |body|)
(RETURN
- (COND
- ((AND (CONSP |y|) (EQ (CAR |y|) 'COLLECT))
- (SETQ |body| (CADR |y|)) (SETQ |itl| (CADDR |y|))
- (SETQ |a|
- (COND
- ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE))
- (CADR |op|))
- (T |op|)))
- (COND
- ((EQ |a| '|append!|)
- (|bfDoCollect| |body| |itl| '|lastNode| '|skipNil|))
- ((EQ |a| '|append|)
- (|bfDoCollect| (LIST '|copyList| |body|) |itl| '|lastNode|
- '|skipNil|))
- (T (SETQ |op| (|bfReName| |a|))
- (SETQ |init|
- (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA)))
- (|bfOpReduce| |op| |init| |body| |itl|))))
- (T (SETQ |seq|
- (COND ((NULL |y|) (|bfTuple| NIL)) (T (CADR |y|))))
- (|bfReduce| |op| (|bfTupleConstruct| |seq|)))))))
+ (COND
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'COLLECT)) (SETQ |body| (CADR |y|))
+ (SETQ |itl| (CADDR |y|))
+ (SETQ |a|
+ (COND ((AND (CONSP |op|) (EQ (CAR |op|) 'QUOTE)) (CADR |op|))
+ (T |op|)))
+ (COND
+ ((EQ |a| '|append!|)
+ (|bfDoCollect| |body| |itl| '|lastNode| '|skipNil|))
+ ((EQ |a| '|append|)
+ (|bfDoCollect| (LIST '|copyList| |body|) |itl| '|lastNode|
+ '|skipNil|))
+ (T (SETQ |op| (|bfReName| |a|))
+ (SETQ |init| (OR (GET |a| 'SHOETHETA) (GET |op| 'SHOETHETA)))
+ (|bfOpReduce| |op| |init| |body| |itl|))))
+ (T (SETQ |seq| (COND ((NULL |y|) (|bfTuple| NIL)) (T (CADR |y|))))
+ (|bfReduce| |op| (|bfTupleConstruct| |seq|)))))))
(DEFUN |bfDCollect| (|y| |itl|) (LIST 'COLLECT |y| |itl|))
@@ -553,154 +512,255 @@
(DEFUN |bfCollect| (|y| |itl|)
(PROG (|a| |ISTMP#1|)
(RETURN
- (COND
- ((AND (CONSP |y|) (EQ (CAR |y|) 'COLON)
- (PROGN
- (SETQ |ISTMP#1| (CDR |y|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |a| (CAR |ISTMP#1|)) T))))
- (COND
- ((OR (AND (CONSP |a|) (EQ (CAR |a|) 'CONS))
- (AND (CONSP |a|) (EQ (CAR |a|) 'LIST)))
- (|bfDoCollect| |a| |itl| '|lastNode| '|skipNil|))
- (T (|bfDoCollect| (LIST '|copyList| |a|) |itl| '|lastNode|
- '|skipNil|))))
- ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE))
- (|bfDoCollect| (|bfConstruct| |y|) |itl| '|lastNode|
- '|skipNil|))
- (T (|bfDoCollect| (LIST 'CONS |y| 'NIL) |itl| 'CDR NIL))))))
+ (COND
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'COLON)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |y|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |a| (CAR |ISTMP#1|)) T))))
+ (COND
+ ((OR (AND (CONSP |a|) (EQ (CAR |a|) 'CONS))
+ (AND (CONSP |a|) (EQ (CAR |a|) 'LIST)))
+ (|bfDoCollect| |a| |itl| '|lastNode| '|skipNil|))
+ (T
+ (|bfDoCollect| (LIST '|copyList| |a|) |itl| '|lastNode| '|skipNil|))))
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE))
+ (|bfDoCollect| (|bfConstruct| |y|) |itl| '|lastNode| '|skipNil|))
+ (T (|bfDoCollect| (LIST 'CONS |y| 'NIL) |itl| 'CDR NIL))))))
(DEFUN |bfMakeCollectInsn| (|expr| |prev| |head| |adv|)
(PROG (|otherTime| |firstTime|)
(RETURN
- (PROGN
- (SETQ |firstTime|
+ (PROGN
+ (SETQ |firstTime|
(|bfMKPROGN|
- (LIST (LIST 'SETQ |head| |expr|)
- (LIST 'SETQ |prev|
- (COND
- ((EQ |adv| 'CDR) |head|)
- (T (LIST |adv| |head|)))))))
- (SETQ |otherTime|
+ (LIST (LIST 'SETQ |head| |expr|)
+ (LIST 'SETQ |prev|
+ (COND ((EQ |adv| 'CDR) |head|)
+ (T (LIST |adv| |head|)))))))
+ (SETQ |otherTime|
(|bfMKPROGN|
- (LIST (LIST 'RPLACD |prev| |expr|)
- (LIST 'SETQ |prev| (LIST |adv| |prev|)))))
- (|bfIf| (LIST 'NULL |head|) |firstTime| |otherTime|)))))
+ (LIST (LIST 'RPLACD |prev| |expr|)
+ (LIST 'SETQ |prev| (LIST |adv| |prev|)))))
+ (|bfIf| (LIST 'NULL |head|) |firstTime| |otherTime|)))))
(DEFUN |bfDoCollect| (|expr| |itl| |adv| |k|)
(PROG (|extrait| |body| |x| |prev| |head|)
(RETURN
- (PROGN
- (SETQ |head| (|bfGenSymbol|))
- (SETQ |prev| (|bfGenSymbol|))
- (SETQ |body|
+ (PROGN
+ (SETQ |head| (|bfGenSymbol|))
+ (SETQ |prev| (|bfGenSymbol|))
+ (SETQ |body|
(COND
- ((EQ |k| '|skipNil|) (SETQ |x| (|bfGenSymbol|))
- (LIST 'LET (LIST (LIST |x| |expr|))
- (|bfIf| (LIST 'NULL |x|) 'NIL
- (|bfMakeCollectInsn| |x| |prev| |head|
- |adv|))))
- (T (|bfMakeCollectInsn| |expr| |prev| |head| |adv|))))
- (SETQ |extrait|
- (LIST (LIST (LIST |head| |prev|) (LIST 'NIL 'NIL) NIL NIL
- NIL (LIST |head|))))
- (|bfLp2| |extrait| |itl| |body|)))))
+ ((EQ |k| '|skipNil|) (SETQ |x| (|bfGenSymbol|))
+ (LIST 'LET (LIST (LIST |x| |expr|))
+ (|bfIf| (LIST 'NULL |x|) 'NIL
+ (|bfMakeCollectInsn| |x| |prev| |head| |adv|))))
+ (T (|bfMakeCollectInsn| |expr| |prev| |head| |adv|))))
+ (SETQ |extrait|
+ (LIST
+ (LIST (LIST |head| |prev|) (LIST 'NIL 'NIL) NIL NIL NIL
+ (LIST |head|))))
+ (|bfLp2| |extrait| |itl| |body|)))))
+
+(DEFUN |separateIterators| (|iters|)
+ (PROG (|y| |x|)
+ (RETURN
+ (PROGN
+ (SETQ |x| NIL)
+ (SETQ |y| NIL)
+ (LET ((|bfVar#1| |iters|) (|iter| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |iter| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ ((AND (CONSP |iter|) (EQ (CAR |iter|) '|%tbliter|))
+ (SETQ |y| (CONS (CDR |iter|) |y|)))
+ (T (SETQ |x| (CONS |iter| |x|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (LIST (|reverse!| |x|) (|reverse!| |y|))))))
+
+(DEFUN |bfExpandTableIters| (|iters|)
+ (PROG (|ISTMP#5| |v| |ISTMP#4| CONS |ISTMP#3| |k| |x| |g| |ISTMP#2| |t|
+ |ISTMP#1| |e| |exits| |localBindings| |inits|)
+ (RETURN
+ (PROGN
+ (SETQ |inits| NIL)
+ (SETQ |localBindings| NIL)
+ (SETQ |exits| NIL)
+ (LET ((|bfVar#2| |iters|) (|bfVar#1| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#2|))
+ (PROGN (SETQ |bfVar#1| (CAR |bfVar#2|)) NIL))
+ (RETURN NIL))
+ (T
+ (AND (CONSP |bfVar#1|)
+ (PROGN
+ (SETQ |e| (CAR |bfVar#1|))
+ (SETQ |ISTMP#1| (CDR |bfVar#1|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |t| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |g| (CAR |ISTMP#2|)) T)))))
+ (PROGN
+ (SETQ |inits| (CONS (LIST |g| |t|) |inits|))
+ (SETQ |x| (GENSYM))
+ (SETQ |exits| (CONS (LIST 'NOT |x|) |exits|))
+ (COND
+ ((AND (CONSP |e|) (EQ (CAR |e|) 'CONS)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |e|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |k| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN
+ (SETQ |ISTMP#3| (CAR |ISTMP#2|))
+ (AND (CONSP |ISTMP#3|)
+ (PROGN
+ (SETQ CONS (CAR |ISTMP#3|))
+ (SETQ |ISTMP#4| (CDR |ISTMP#3|))
+ (AND (CONSP |ISTMP#4|)
+ (PROGN
+ (SETQ |v| (CAR |ISTMP#4|))
+ (SETQ |ISTMP#5|
+ (CDR |ISTMP#4|))
+ (AND (CONSP |ISTMP#5|)
+ (NULL (CDR |ISTMP#5|))
+ (EQ (CAR |ISTMP#5|)
+ 'NIL)))))))))))
+ (|ident?| |k|) (|ident?| |v|))
+ (SETQ |localBindings|
+ (CONS
+ (LIST 'MULTIPLE-VALUE-BIND (LIST |x| |k| |v|)
+ (LIST |g|))
+ |localBindings|)))
+ (T (SETQ |k| (GENSYM)) (SETQ |v| (GENSYM))
+ (SETQ |localBindings|
+ (CONS
+ (LIST 'MULTIPLE-VALUE-BIND (LIST |x| |k| |v|)
+ (LIST |g|)
+ (|bfLET1|
+ (LIST 'CONS |k| (LIST 'CONS |v| 'NIL)) |e|))
+ |localBindings|))))))))
+ (SETQ |bfVar#2| (CDR |bfVar#2|))))
+ (LIST |inits| |localBindings| |exits|)))))
(DEFUN |bfLp1| (|iters| |body|)
- (PROG (|loop| |nbody| |value| |exits| |filters| |sucs| |inits| |vars|
- |LETTMP#1|)
- (RETURN
- (PROGN
- (SETQ |LETTMP#1| (|bfSep| (|bfAppend| |iters|)))
- (SETQ |vars| (CAR |LETTMP#1|))
- (SETQ |inits| (CADR . #0=(|LETTMP#1|)))
- (SETQ |sucs| (CADDR . #0#))
- (SETQ |filters| (CADDDR . #0#))
- (SETQ |exits| (CAR #1=(CDDDDR . #0#)))
- (SETQ |value| (CADR #1#))
- (SETQ |nbody|
- (COND
- ((NULL |filters|) |body|)
- (T (|bfAND| (|append| |filters| (CONS |body| NIL))))))
- (SETQ |value| (COND ((NULL |value|) 'NIL) (T (CAR |value|))))
- (SETQ |exits|
- (COND
- ((NULL |exits|) |nbody|)
- (T (|bfIf| (|bfOR| |exits|) (LIST 'RETURN |value|)
- |nbody|))))
- (SETQ |loop| (CONS 'LOOP (CONS |exits| |sucs|)))
- (COND
- (|vars| (SETQ |loop|
- (LIST 'LET
- (LET ((|bfVar#3| NIL) (|bfVar#4| NIL)
- (|bfVar#1| |vars|) (|v| NIL)
- (|bfVar#2| |inits|) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN
- (SETQ |v| (CAR |bfVar#1|))
- NIL)
- (NOT (CONSP |bfVar#2|))
- (PROGN
- (SETQ |i| (CAR |bfVar#2|))
- NIL))
- (RETURN |bfVar#3|))
- ((NULL |bfVar#3|)
- (SETQ |bfVar#3|
- #2=(CONS (LIST |v| |i|) NIL))
- (SETQ |bfVar#4| |bfVar#3|))
- (T (RPLACD |bfVar#4| #2#)
- (SETQ |bfVar#4| (CDR |bfVar#4|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))
- (SETQ |bfVar#2| (CDR |bfVar#2|))))
- |loop|))))
- |loop|))))
+ (PROG (|loop| |nbody| |tblExits| |tblLocs| |tblInits| |value| |exits|
+ |filters| |sucs| |inits| |vars| |tbls| |LETTMP#1|)
+ (RETURN
+ (PROGN
+ (SETQ |LETTMP#1| (|separateIterators| |iters|))
+ (SETQ |iters| (CAR |LETTMP#1|))
+ (SETQ |tbls| (CADR |LETTMP#1|))
+ (SETQ |LETTMP#1| (|bfSep| (|bfAppend| |iters|)))
+ (SETQ |vars| (CAR |LETTMP#1|))
+ (SETQ |inits| (CADR . #1=(|LETTMP#1|)))
+ (SETQ |sucs| (CADDR . #1#))
+ (SETQ |filters| (CADDDR . #1#))
+ (SETQ |exits| (CAR #2=(CDDDDR . #1#)))
+ (SETQ |value| (CADR #2#))
+ (SETQ |LETTMP#1| (|bfExpandTableIters| |tbls|))
+ (SETQ |tblInits| (CAR |LETTMP#1|))
+ (SETQ |tblLocs| (CADR . #3=(|LETTMP#1|)))
+ (SETQ |tblExits| (CADDR . #3#))
+ (SETQ |nbody|
+ (COND ((NULL |filters|) |body|)
+ (T (|bfAND| (|append| |filters| (CONS |body| NIL))))))
+ (SETQ |value| (COND ((NULL |value|) 'NIL) (T (CAR |value|))))
+ (SETQ |exits|
+ (COND ((AND (NULL |exits|) (NULL |tblExits|)) |nbody|)
+ (T
+ (|bfIf| (|bfOR| (|append| |exits| |tblExits|))
+ (LIST 'RETURN |value|) |nbody|))))
+ (LET ((|bfVar#1| |tblLocs|) (|locBinding| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |locBinding| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETQ |exits| (|append| |locBinding| (CONS |exits| NIL)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (SETQ |loop| (CONS 'LOOP (CONS |exits| |sucs|)))
+ (COND
+ (|vars|
+ (SETQ |loop|
+ (LIST 'LET
+ (LET ((|bfVar#4| NIL)
+ (|bfVar#5| NIL)
+ (|bfVar#2| |vars|)
+ (|v| NIL)
+ (|bfVar#3| |inits|)
+ (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#2|))
+ (PROGN (SETQ |v| (CAR |bfVar#2|)) NIL)
+ (NOT (CONSP |bfVar#3|))
+ (PROGN (SETQ |i| (CAR |bfVar#3|)) NIL))
+ (RETURN |bfVar#4|))
+ ((NULL |bfVar#4|)
+ (SETQ |bfVar#4| #4=(CONS (LIST |v| |i|) NIL))
+ (SETQ |bfVar#5| |bfVar#4|))
+ (T (RPLACD |bfVar#5| #4#)
+ (SETQ |bfVar#5| (CDR |bfVar#5|))))
+ (SETQ |bfVar#2| (CDR |bfVar#2|))
+ (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ |loop|))))
+ (LET ((|bfVar#6| |tblInits|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#6|)) (PROGN (SETQ |x| (CAR |bfVar#6|)) NIL))
+ (RETURN NIL))
+ (T (SETQ |loop| (LIST 'WITH-HASH-TABLE-ITERATOR |x| |loop|))))
+ (SETQ |bfVar#6| (CDR |bfVar#6|))))
+ |loop|))))
(DEFUN |bfLp2| (|extrait| |itl| |body|)
(PROG (|iters|)
(RETURN
- (COND
- ((AND (CONSP |itl|) (EQ (CAR |itl|) 'ITERATORS))
- (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|))
- (T (SETQ |iters| (CDR |itl|))
- (|bfLpCross|
- (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|)))
- (CDR |iters|))
- |body|))))))
+ (COND
+ ((AND (CONSP |itl|) (EQ (CAR |itl|) 'ITERATORS))
+ (|bfLp1| (CONS |extrait| (CDR |itl|)) |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|)
(RETURN
- (PROGN
- (SETQ |g| (|bfGenSymbol|))
- (SETQ |body|
+ (PROGN
+ (SETQ |g| (|bfGenSymbol|))
+ (SETQ |body|
(COND
- ((EQ |op| 'AND)
- (|bfMKPROGN|
- (LIST (LIST 'SETQ |g| |y|)
- (LIST 'COND
- (LIST (LIST 'NOT |g|)
- (LIST 'RETURN 'NIL))))))
- ((EQ |op| 'OR)
- (|bfMKPROGN|
- (LIST (LIST 'SETQ |g| |y|)
- (LIST 'COND (LIST |g| (LIST 'RETURN |g|))))))
- (T (LIST 'SETQ |g| (LIST |op| |g| |y|)))))
- (COND
- ((NULL |init|) (SETQ |g1| (|bfGenSymbol|))
- (SETQ |init| (LIST 'CAR |g1|)) (SETQ |y| (LIST 'CDR |g1|))
- (SETQ |extrait|
- (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL
- (LIST |g|))))
- (|bfMKPROGN|
- (LIST (LIST 'L%T |g1| |y|)
- (|bfLp2| |extrait| |itl| |body|))))
- (T (SETQ |init| (CAR |init|))
- (SETQ |extrait|
- (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL
- (LIST |g|))))
- (|bfLp2| |extrait| |itl| |body|)))))))
+ ((EQ |op| 'AND)
+ (|bfMKPROGN|
+ (LIST (LIST 'SETQ |g| |y|)
+ (LIST 'COND
+ (LIST (LIST 'NOT |g|) (LIST 'RETURN 'NIL))))))
+ ((EQ |op| 'OR)
+ (|bfMKPROGN|
+ (LIST (LIST 'SETQ |g| |y|)
+ (LIST 'COND (LIST |g| (LIST 'RETURN |g|))))))
+ (T (LIST 'SETQ |g| (LIST |op| |g| |y|)))))
+ (COND
+ ((NULL |init|) (SETQ |g1| (|bfGenSymbol|))
+ (SETQ |init| (LIST 'CAR |g1|)) (SETQ |y| (LIST 'CDR |g1|))
+ (SETQ |extrait|
+ (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|))))
+ (|bfMKPROGN|
+ (LIST (LIST 'L%T |g1| |y|) (|bfLp2| |extrait| |itl| |body|))))
+ (T (SETQ |init| (CAR |init|))
+ (SETQ |extrait|
+ (LIST (LIST (LIST |g|) (LIST |init|) NIL NIL NIL (LIST |g|))))
+ (|bfLp2| |extrait| |itl| |body|)))))))
(DEFUN |bfLoop1| (|body|) (|bfLp| (|bfIterators| NIL) |body|))
@@ -714,1546 +774,1442 @@
(DEFUN |bfForin| (|lhs| U) (|bfFor| |lhs| U 1))
(DEFUN |bfLocal| (|a| |b|)
- (COND
- ((EQ |b| 'FLUID) (|compFluid| |a|))
- ((EQ |b| '|local|) (|compFluid| |a|))
- (T |a|)))
+ (COND ((EQ |b| 'FLUID) (|compFluid| |a|))
+ ((EQ |b| '|local|) (|compFluid| |a|)) (T |a|)))
(DEFUN |bfTake| (|n| |x|)
- (COND
- ((NULL |x|) |x|)
- ((EQL |n| 0) NIL)
- (T (CONS (CAR |x|) (|bfTake| (- |n| 1) (CDR |x|))))))
+ (COND ((NULL |x|) |x|) ((EQL |n| 0) NIL)
+ (T (CONS (CAR |x|) (|bfTake| (- |n| 1) (CDR |x|))))))
(DEFUN |bfDrop| (|n| |x|)
- (COND
- ((OR (NULL |x|) (EQL |n| 0)) |x|)
- (T (|bfDrop| (- |n| 1) (CDR |x|)))))
+ (COND ((OR (NULL |x|) (EQL |n| 0)) |x|) (T (|bfDrop| (- |n| 1) (CDR |x|)))))
(DEFUN |bfReturnNoName| (|a|) (LIST 'RETURN |a|))
(DEFUN |bfLeave| (|x|) (LIST '|%Leave| |x|))
(DEFUN |bfSUBLIS| (|p| |e|)
- (COND
- ((NOT (CONSP |e|)) (|bfSUBLIS1| |p| |e|))
- ((EQ (CAR |e|) 'QUOTE) |e|)
- (T (CONS (|bfSUBLIS| |p| (CAR |e|)) (|bfSUBLIS| |p| (CDR |e|))))))
+ (COND ((NOT (CONSP |e|)) (|bfSUBLIS1| |p| |e|)) ((EQ (CAR |e|) 'QUOTE) |e|)
+ (T (CONS (|bfSUBLIS| |p| (CAR |e|)) (|bfSUBLIS| |p| (CDR |e|))))))
(DEFUN |bfSUBLIS1| (|p| |e|)
(PROG (|f|)
(RETURN
- (COND
- ((NULL |p|) |e|)
- (T (SETQ |f| (CAR |p|))
- (COND
- ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|)))
- (T (|bfSUBLIS1| (CDR |p|) |e|))))))))
+ (COND ((NULL |p|) |e|)
+ (T (SETQ |f| (CAR |p|))
+ (COND ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|)))
+ (T (|bfSUBLIS1| (CDR |p|) |e|))))))))
(DEFUN |defSheepAndGoats| (|x|)
(PROG (|defstack| |op1| |opassoc| |argl|)
(DECLARE (SPECIAL |$op|))
(RETURN
- (CASE (CAR |x|)
- (|%Definition|
- (LET ((|op| (CADR |x|)) (|args| (CADDR |x|))
- (|body| (CADDDR |x|)))
- (PROGN
- (SETQ |argl|
- (COND
- ((|bfTupleP| |args|) (CDR |args|))
- (T (LIST |args|))))
- (COND
- ((NULL |argl|)
- (SETQ |opassoc| (LIST (CONS |op| |body|)))
- (LIST |opassoc| NIL NIL))
- (T (SETQ |op1|
- (INTERN (CONCAT (SYMBOL-NAME |$op|) ","
- (SYMBOL-NAME |op|))))
- (SETQ |opassoc| (LIST (CONS |op| |op1|)))
- (SETQ |defstack|
- (LIST (LIST |op1| |args| |body|)))
- (LIST |opassoc| |defstack| NIL))))))
- (|%Pile| (LET ((|defs| (CADR |x|)))
- (|defSheepAndGoatsList| |defs|)))
- (T (LIST NIL NIL (LIST |x|)))))))
+ (CASE (CAR |x|)
+ (|%Definition|
+ (LET ((|op| (CADR |x|)) (|args| (CADDR |x|)) (|body| (CADDDR |x|)))
+ (PROGN
+ (SETQ |argl|
+ (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|))))
+ (COND
+ ((NULL |argl|) (SETQ |opassoc| (LIST (CONS |op| |body|)))
+ (LIST |opassoc| NIL NIL))
+ (T
+ (SETQ |op1|
+ (INTERN
+ (CONCAT (SYMBOL-NAME |$op|) "," (SYMBOL-NAME |op|))))
+ (SETQ |opassoc| (LIST (CONS |op| |op1|)))
+ (SETQ |defstack| (LIST (LIST |op1| |args| |body|)))
+ (LIST |opassoc| |defstack| NIL))))))
+ (|%Pile|
+ (LET ((|defs| (CADR |x|)))
+ (|defSheepAndGoatsList| |defs|)))
+ (T (LIST NIL NIL (LIST |x|)))))))
(DEFUN |defSheepAndGoatsList| (|x|)
- (PROG (|nondefs1| |defs1| |opassoc1| |nondefs| |defs| |opassoc|
- |LETTMP#1|)
- (RETURN
- (COND
- ((NULL |x|) (LIST NIL NIL NIL))
- (T (SETQ |LETTMP#1| (|defSheepAndGoats| (CAR |x|)))
- (SETQ |opassoc| (CAR |LETTMP#1|))
- (SETQ |defs| (CADR . #0=(|LETTMP#1|)))
- (SETQ |nondefs| (CADDR . #0#))
- (SETQ |LETTMP#1| (|defSheepAndGoatsList| (CDR |x|)))
- (SETQ |opassoc1| (CAR |LETTMP#1|))
- (SETQ |defs1| (CADR . #1=(|LETTMP#1|)))
- (SETQ |nondefs1| (CADDR . #1#))
- (LIST (|append| |opassoc| |opassoc1|)
- (|append| |defs| |defs1|)
- (|append| |nondefs| |nondefs1|)))))))
+ (PROG (|nondefs1| |defs1| |opassoc1| |nondefs| |defs| |opassoc| |LETTMP#1|)
+ (RETURN
+ (COND ((NULL |x|) (LIST NIL NIL NIL))
+ (T (SETQ |LETTMP#1| (|defSheepAndGoats| (CAR |x|)))
+ (SETQ |opassoc| (CAR |LETTMP#1|))
+ (SETQ |defs| (CADR . #1=(|LETTMP#1|)))
+ (SETQ |nondefs| (CADDR . #1#))
+ (SETQ |LETTMP#1| (|defSheepAndGoatsList| (CDR |x|)))
+ (SETQ |opassoc1| (CAR |LETTMP#1|))
+ (SETQ |defs1| (CADR . #2=(|LETTMP#1|)))
+ (SETQ |nondefs1| (CADDR . #2#))
+ (LIST (|append| |opassoc| |opassoc1|) (|append| |defs| |defs1|)
+ (|append| |nondefs| |nondefs1|)))))))
(DEFUN |bfLetForm| (|lhs| |rhs|) (LIST 'L%T |lhs| |rhs|))
(DEFUN |bfLET1| (|lhs| |rhs|)
(PROG (|let1| |g| |l2| |l1| |name| |rhs1| |ISTMP#1|)
(RETURN
- (COND
- ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|))
- ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))
- (|bfLetForm| |lhs| |rhs|))
- ((AND (SYMBOLP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|)))
- (SETQ |rhs1| (|bfLET2| |lhs| |rhs|))
- (COND
- ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'L%T))
- (|bfMKPROGN| (LIST |rhs1| |rhs|)))
- ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'PROGN))
- (|append| |rhs1| (LIST |rhs|)))
- (T (COND
- ((SYMBOLP (CAR |rhs1|))
- (SETQ |rhs1| (CONS |rhs1| NIL))))
+ (COND ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|))
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))
+ (|bfLetForm| |lhs| |rhs|))
+ ((AND (SYMBOLP |rhs|) (NOT (|bfCONTAINED| |rhs| |lhs|)))
+ (SETQ |rhs1| (|bfLET2| |lhs| |rhs|))
+ (COND
+ ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'L%T))
+ (|bfMKPROGN| (LIST |rhs1| |rhs|)))
+ ((AND (CONSP |rhs1|) (EQ (CAR |rhs1|) 'PROGN))
+ (|append| |rhs1| (LIST |rhs|)))
+ (T (COND ((SYMBOLP (CAR |rhs1|)) (SETQ |rhs1| (CONS |rhs1| NIL))))
(|bfMKPROGN| (|append| |rhs1| (CONS |rhs| NIL))))))
- ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T)
- (SYMBOLP (SETQ |name| (CADR |rhs|))))
- (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|)))
- (SETQ |l2| (|bfLET1| |lhs| |name|))
- (COND
- ((AND (CONSP |l2|) (EQ (CAR |l2|) 'PROGN))
- (|bfMKPROGN| (CONS |l1| (CDR |l2|))))
- (T (COND
- ((SYMBOLP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL))))
- (|bfMKPROGN|
- (CONS |l1| (|append| |l2| (CONS |name| NIL)))))))
- (T (SETQ |g| (|bfLetVar|)) (SETQ |rhs1| (LIST 'L%T |g| |rhs|))
- (SETQ |let1| (|bfLET1| |lhs| |g|))
- (COND
+ ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T)
+ (SYMBOLP (SETQ |name| (CADR |rhs|))))
+ (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|)))
+ (SETQ |l2| (|bfLET1| |lhs| |name|))
+ (COND
+ ((AND (CONSP |l2|) (EQ (CAR |l2|) 'PROGN))
+ (|bfMKPROGN| (CONS |l1| (CDR |l2|))))
+ (T (COND ((SYMBOLP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL))))
+ (|bfMKPROGN| (CONS |l1| (|append| |l2| (CONS |name| NIL)))))))
+ (T (SETQ |g| (|bfLetVar|)) (SETQ |rhs1| (LIST 'L%T |g| |rhs|))
+ (SETQ |let1| (|bfLET1| |lhs| |g|))
+ (COND
((AND (CONSP |let1|) (EQ (CAR |let1|) 'PROGN))
(|bfMKPROGN| (CONS |rhs1| (CDR |let1|))))
- (T (COND
- ((SYMBOLP (CAR |let1|))
- (SETQ |let1| (CONS |let1| NIL))))
- (|bfMKPROGN|
- (CONS |rhs1| (|append| |let1| (CONS |g| NIL)))))))))))
+ (T (COND ((SYMBOLP (CAR |let1|)) (SETQ |let1| (CONS |let1| NIL))))
+ (|bfMKPROGN|
+ (CONS |rhs1| (|append| |let1| (CONS |g| NIL)))))))))))
(DEFUN |bfCONTAINED| (|x| |y|)
- (COND
- ((EQ |x| |y|) T)
- ((NOT (CONSP |y|)) NIL)
- (T (OR (|bfCONTAINED| |x| (CAR |y|)) (|bfCONTAINED| |x| (CDR |y|))))))
+ (COND ((EQ |x| |y|) T) ((NOT (CONSP |y|)) NIL)
+ (T (OR (|bfCONTAINED| |x| (CAR |y|)) (|bfCONTAINED| |x| (CDR |y|))))))
(DEFUN |bfLET2| (|lhs| |rhs|)
- (PROG (|isPred| |val1| |ISTMP#3| |g| |rev| |patrev| |l2| |l1| |var2|
- |var1| |b| |ISTMP#2| |a| |ISTMP#1|)
+ (PROG (|isPred| |val1| |ISTMP#3| |g| |rev| |patrev| |l2| |l1| |var2| |var1|
+ |b| |ISTMP#2| |a| |ISTMP#1|)
(DECLARE (SPECIAL |$inDefIS|))
(RETURN
- (COND
- ((NULL |lhs|) NIL)
- ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|))
- ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))
- (|bfLetForm| |lhs| |rhs|))
- ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |a| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |b| (CAR |ISTMP#2|)) T))))))
- (SETQ |a| (|bfLET2| |a| |rhs|))
- (COND
- ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|)
- ((NOT (CONSP |b|)) (LIST |a| |b|))
- ((CONSP (CAR |b|)) (CONS |a| |b|))
- (T (LIST |a| |b|))))
- ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'CONS)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |var1| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T))))))
- (COND
- ((OR (EQ |var1| 'DOT)
- (AND (CONSP |var1|) (EQ (CAR |var1|) 'QUOTE)))
- (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|)))
- (T (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|)))
- (COND
- ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|)
- (T (COND
- ((AND (CONSP |l1|) (NOT (CONSP (CAR |l1|))))
- (SETQ |l1| (CONS |l1| NIL))))
- (COND
- ((SYMBOLP |var2|)
- (|append| |l1|
- (CONS (|bfLetForm| |var2|
- (|addCARorCDR| 'CDR |rhs|))
- NIL)))
- (T (SETQ |l2|
- (|bfLET2| |var2|
- (|addCARorCDR| 'CDR |rhs|)))
- (COND
- ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|))))
- (SETQ |l2| (CONS |l2| NIL))))
- (|append| |l1| |l2|))))))))
- ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|append|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |var1| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T))))))
- (SETQ |patrev| (|bfISReverse| |var2| |var1|))
- (SETQ |rev| (LIST '|reverse| |rhs|)) (SETQ |g| (|bfLetVar|))
- (SETQ |l2| (|bfLET2| |patrev| |g|))
- (COND
- ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|))))
- (SETQ |l2| (CONS |l2| NIL))))
- (COND
- ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|))
- ((PROGN
- (SETQ |ISTMP#1| (CAR (|lastNode| |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|)
- (NULL (CDR |ISTMP#3|))
- (PROGN
- (SETQ |val1| (CAR |ISTMP#3|))
- T)))))))
- (CONS (LIST 'L%T |g| |rev|)
- (|append| (|reverse| (CDR (|reverse| |l2|)))
- (CONS (|bfLetForm| |var1|
- (LIST '|reverse!| |val1|))
- NIL))))
- (T (CONS (LIST 'L%T |g| |rev|)
- (|append| |l2|
- (CONS (|bfLetForm| |var1|
- (LIST '|reverse!| |var1|))
- NIL))))))
- ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |var1| (CAR |ISTMP#1|)) T))))
- (LIST 'COND (LIST (|bfQ| |var1| |rhs|) |var1|)))
- (T (SETQ |isPred|
- (COND
- (|$inDefIS| (|bfIS1| |rhs| |lhs|))
- (T (|bfIS| |rhs| |lhs|))))
- (LIST 'COND (LIST |isPred| |rhs|)))))))
+ (COND ((NULL |lhs|) NIL) ((SYMBOLP |lhs|) (|bfLetForm| |lhs| |rhs|))
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|)))))
+ (|bfLetForm| |lhs| |rhs|))
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'L%T)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |a| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |b| (CAR |ISTMP#2|)) T))))))
+ (SETQ |a| (|bfLET2| |a| |rhs|))
+ (COND ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|)
+ ((NOT (CONSP |b|)) (LIST |a| |b|))
+ ((CONSP (CAR |b|)) (CONS |a| |b|)) (T (LIST |a| |b|))))
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'CONS)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |var1| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T))))))
+ (COND
+ ((OR (EQ |var1| 'DOT)
+ (AND (CONSP |var1|) (EQ (CAR |var1|) 'QUOTE)))
+ (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|)))
+ (T (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|)))
+ (COND ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|)
+ (T
+ (COND
+ ((AND (CONSP |l1|) (NOT (CONSP (CAR |l1|))))
+ (SETQ |l1| (CONS |l1| NIL))))
+ (COND
+ ((SYMBOLP |var2|)
+ (|append| |l1|
+ (CONS
+ (|bfLetForm| |var2|
+ (|addCARorCDR| 'CDR |rhs|))
+ NIL)))
+ (T
+ (SETQ |l2| (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|)))
+ (COND
+ ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|))))
+ (SETQ |l2| (CONS |l2| NIL))))
+ (|append| |l1| |l2|))))))))
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|append|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |var1| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |var2| (CAR |ISTMP#2|)) T))))))
+ (SETQ |patrev| (|bfISReverse| |var2| |var1|))
+ (SETQ |rev| (LIST '|reverse| |rhs|)) (SETQ |g| (|bfLetVar|))
+ (SETQ |l2| (|bfLET2| |patrev| |g|))
+ (COND
+ ((AND (CONSP |l2|) (NOT (CONSP (CAR |l2|))))
+ (SETQ |l2| (CONS |l2| NIL))))
+ (COND ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|))
+ ((PROGN
+ (SETQ |ISTMP#1| (CAR (|lastNode| |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|) (NULL (CDR |ISTMP#3|))
+ (PROGN
+ (SETQ |val1| (CAR |ISTMP#3|))
+ T)))))))
+ (CONS (LIST 'L%T |g| |rev|)
+ (|append| (|reverse| (CDR (|reverse| |l2|)))
+ (CONS
+ (|bfLetForm| |var1|
+ (LIST '|reverse!| |val1|))
+ NIL))))
+ (T
+ (CONS (LIST 'L%T |g| |rev|)
+ (|append| |l2|
+ (CONS
+ (|bfLetForm| |var1|
+ (LIST '|reverse!| |var1|))
+ NIL))))))
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |var1| (CAR |ISTMP#1|)) T))))
+ (LIST 'COND (LIST (|bfQ| |var1| |rhs|) |var1|)))
+ (T
+ (SETQ |isPred|
+ (COND (|$inDefIS| (|bfIS1| |rhs| |lhs|))
+ (T (|bfIS| |rhs| |lhs|))))
+ (LIST 'COND (LIST |isPred| |rhs|)))))))
(DEFUN |bfLET| (|lhs| |rhs|)
(PROG (|$letGenVarCounter|)
(DECLARE (SPECIAL |$letGenVarCounter|))
- (RETURN
- (PROGN (SETQ |$letGenVarCounter| 0) (|bfLET1| |lhs| |rhs|)))))
+ (RETURN (PROGN (SETQ |$letGenVarCounter| 0) (|bfLET1| |lhs| |rhs|)))))
(DEFUN |addCARorCDR| (|acc| |expr|)
(PROG (|funsR| |funsA| |p| |funs|)
(RETURN
- (COND
- ((NOT (CONSP |expr|)) (LIST |acc| |expr|))
- ((AND (EQ |acc| 'CAR) (CONSP |expr|)
- (EQ (CAR |expr|) '|reverse|))
- (LIST 'CAR (CONS '|lastNode| (CDR |expr|))))
- (T (SETQ |funs|
- '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR
- CDAAR CDDAR CDADR CDDDR))
- (SETQ |p| (|bfPosition| (CAR |expr|) |funs|))
- (COND
- ((EQL |p| (- 1)) (LIST |acc| |expr|))
- (T (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|)))))))))))
+ (COND ((NOT (CONSP |expr|)) (LIST |acc| |expr|))
+ ((AND (EQ |acc| 'CAR) (CONSP |expr|) (EQ (CAR |expr|) '|reverse|))
+ (LIST 'CAR (CONS '|lastNode| (CDR |expr|))))
+ (T
+ (SETQ |funs|
+ '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR CDAAR
+ CDDAR CDADR CDDDR))
+ (SETQ |p| (|bfPosition| (CAR |expr|) |funs|))
+ (COND ((EQL |p| (- 1)) (LIST |acc| |expr|))
+ (T
+ (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))
(DEFUN |bfPosn| (|x| |l| |n|)
- (COND
- ((NULL |l|) (- 1))
- ((EQUAL |x| (CAR |l|)) |n|)
- (T (|bfPosn| |x| (CDR |l|) (+ |n| 1)))))
+ (COND ((NULL |l|) (- 1)) ((EQUAL |x| (CAR |l|)) |n|)
+ (T (|bfPosn| |x| (CDR |l|) (+ |n| 1)))))
(DEFUN |bfISApplication| (|op| |left| |right|)
- (COND
- ((EQ |op| 'IS) (|bfIS| |left| |right|))
- ((EQ |op| 'ISNT) (|bfNOT| (|bfIS| |left| |right|)))
- (T (LIST |op| |left| |right|))))
+ (COND ((EQ |op| 'IS) (|bfIS| |left| |right|))
+ ((EQ |op| 'ISNT) (|bfNOT| (|bfIS| |left| |right|)))
+ (T (LIST |op| |left| |right|))))
(DEFUN |bfIS| (|left| |right|)
(PROG (|$inDefIS| |$isGenVarCounter|)
- (DECLARE (SPECIAL |$inDefIS| |$isGenVarCounter|))
+ (DECLARE (SPECIAL |$isGenVarCounter| |$inDefIS|))
(RETURN
- (PROGN
- (SETQ |$isGenVarCounter| 0)
- (SETQ |$inDefIS| T)
- (|bfIS1| |left| |right|)))))
+ (PROGN
+ (SETQ |$isGenVarCounter| 0)
+ (SETQ |$inDefIS| T)
+ (|bfIS1| |left| |right|)))))
(DEFUN |bfISReverse| (|x| |a|)
(PROG (|y|)
(RETURN
- (COND
- ((AND (CONSP |x|) (EQ (CAR |x|) 'CONS))
- (COND
- ((NULL (CADDR |x|)) (LIST 'CONS (CADR |x|) |a|))
- (T (SETQ |y| (|bfISReverse| (CADDR |x|) NIL))
+ (COND
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'CONS))
+ (COND ((NULL (CADDR |x|)) (LIST 'CONS (CADR |x|) |a|))
+ (T (SETQ |y| (|bfISReverse| (CADDR |x|) NIL))
(RPLACA (CDR (CDR |y|)) (LIST 'CONS (CADR |x|) |a|)) |y|)))
- (T (|bpSpecificErrorHere| "Error in bfISReverse") (|bpTrap|))))))
+ (T (|bpSpecificErrorHere| "Error in bfISReverse") (|bpTrap|))))))
(DEFUN |bfIS1| (|lhs| |rhs|)
- (PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |g| |b| |ISTMP#2|
- |ISTMP#1| |l| |d| |c| |a|)
- (RETURN
- (COND
- ((NULL |rhs|) (LIST 'NULL |lhs|))
- ((|bfString?| |rhs|)
- (|bfAND| (LIST (LIST 'STRINGP |lhs|)
- (LIST 'STRING= |lhs| |rhs|))))
- ((OR (|bfChar?| |rhs|) (INTEGERP |rhs|))
- (LIST 'EQL |lhs| |rhs|))
- ((NOT (CONSP |rhs|))
- (LIST 'PROGN (|bfLetForm| |rhs| |lhs|) 'T))
- ((EQ (CAR |rhs|) 'QUOTE) (SETQ |a| (CADR |rhs|))
- (COND
- ((SYMBOLP |a|) (LIST 'EQ |lhs| |rhs|))
- ((STRINGP |a|)
- (|bfAND| (LIST (LIST 'STRINGP |lhs|)
- (LIST 'STRING= |lhs| |a|))))
- (T (LIST 'EQUAL |lhs| |rhs|))))
- ((EQ (CAR |rhs|) 'L%T) (SETQ |c| (CADR . #0=(|rhs|)))
- (SETQ |d| (CADDR . #0#)) (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|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |a| (CAR |ISTMP#1|)) T))))
- (|bfQ| |lhs| |a|))
- ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'CONS)
- (PROGN
- (SETQ |ISTMP#1| (CDR |rhs|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |a| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |b| (CAR |ISTMP#2|)) T)))))
- (EQ |a| 'DOT) (EQ |b| 'DOT))
- (LIST 'CONSP |lhs|))
- ((CONSP |lhs|) (SETQ |g| (|bfIsVar|))
- (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|))))
- ((EQ (CAR |rhs|) 'CONS) (SETQ |a| (CADR . #1=(|rhs|)))
- (SETQ |b| (CADDR . #1#))
- (COND
- ((EQ |a| 'DOT)
+ (PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |g| |b| |ISTMP#2| |ISTMP#1| |l|
+ |d| |c| |a|)
+ (RETURN
+ (COND ((NULL |rhs|) (LIST 'NULL |lhs|))
+ ((|bfString?| |rhs|)
+ (|bfAND| (LIST (LIST 'STRINGP |lhs|) (LIST 'STRING= |lhs| |rhs|))))
+ ((OR (|bfChar?| |rhs|) (INTEGERP |rhs|)) (LIST 'EQL |lhs| |rhs|))
+ ((NOT (CONSP |rhs|)) (LIST 'PROGN (|bfLetForm| |rhs| |lhs|) 'T))
+ ((EQ (CAR |rhs|) 'QUOTE) (SETQ |a| (CADR |rhs|))
+ (COND ((SYMBOLP |a|) (LIST 'EQ |lhs| |rhs|))
+ ((STRINGP |a|)
+ (|bfAND|
+ (LIST (LIST 'STRINGP |lhs|) (LIST 'STRING= |lhs| |a|))))
+ (T (LIST 'EQUAL |lhs| |rhs|))))
+ ((EQ (CAR |rhs|) 'L%T) (SETQ |c| (CADR . #1=(|rhs|)))
+ (SETQ |d| (CADDR . #1#)) (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|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |a| (CAR |ISTMP#1|)) T))))
+ (|bfQ| |lhs| |a|))
+ ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'CONS)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |rhs|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |a| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |b| (CAR |ISTMP#2|)) T)))))
+ (EQ |a| 'DOT) (EQ |b| 'DOT))
+ (LIST 'CONSP |lhs|))
+ ((CONSP |lhs|) (SETQ |g| (|bfIsVar|))
+ (|bfMKPROGN| (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|))))
+ ((EQ (CAR |rhs|) 'CONS) (SETQ |a| (CADR . #2=(|rhs|)))
+ (SETQ |b| (CADDR . #2#))
(COND
- ((NULL |b|)
- (|bfAND| (LIST (LIST 'CONSP |lhs|)
- (LIST 'NULL (LIST 'CDR |lhs|)))))
- ((EQ |b| 'DOT) (LIST 'CONSP |lhs|))
- (T (|bfAND| (LIST (LIST 'CONSP |lhs|)
- (|bfIS1| (LIST 'CDR |lhs|) |b|))))))
- ((NULL |b|)
- (|bfAND| (LIST (LIST 'CONSP |lhs|)
- (LIST 'NULL (LIST 'CDR |lhs|))
- (|bfIS1| (LIST 'CAR |lhs|) |a|))))
- ((EQ |b| 'DOT)
- (|bfAND| (LIST (LIST 'CONSP |lhs|)
- (|bfIS1| (LIST 'CAR |lhs|) |a|))))
- (T (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|))
+ ((EQ |a| 'DOT)
+ (COND
+ ((NULL |b|)
+ (|bfAND|
+ (LIST (LIST 'CONSP |lhs|) (LIST 'NULL (LIST 'CDR |lhs|)))))
+ ((EQ |b| 'DOT) (LIST 'CONSP |lhs|))
+ (T
+ (|bfAND|
+ (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CDR |lhs|) |b|))))))
+ ((NULL |b|)
+ (|bfAND|
+ (LIST (LIST 'CONSP |lhs|) (LIST 'NULL (LIST 'CDR |lhs|))
+ (|bfIS1| (LIST 'CAR |lhs|) |a|))))
+ ((EQ |b| 'DOT)
+ (|bfAND|
+ (LIST (LIST 'CONSP |lhs|) (|bfIS1| (LIST 'CAR |lhs|) |a|))))
+ (T (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|)
- (NULL (CDR |ISTMP#2|))
- (EQ (CAR |ISTMP#2|) '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|)))))))
- ((EQ (CAR |rhs|) '|append|) (SETQ |a| (CADR . #2=(|rhs|)))
- (SETQ |b| (CADDR . #2#))
- (SETQ |patrev| (|bfISReverse| |b| |a|)) (SETQ |g| (|bfIsVar|))
- (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|) (NOT (CONSP (CAR |l2|))))
- (SETQ |l2| (CONS |l2| NIL))))
- (COND
- ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|)))
- (T (|bfAND| (CONS |rev|
- (|append| |l2|
- (CONS (LIST 'PROGN
- (|bfLetForm| |a|
- (LIST '|reverse!| |a|))
- 'T)
- NIL)))))))
- (T (|bpSpecificErrorHere| "bad IS code is generated")
- (|bpTrap|))))))
+ ((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|) (NULL (CDR |ISTMP#2|))
+ (EQ (CAR |ISTMP#2|) '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|)))))))
+ ((EQ (CAR |rhs|) '|append|) (SETQ |a| (CADR . #3=(|rhs|)))
+ (SETQ |b| (CADDR . #3#)) (SETQ |patrev| (|bfISReverse| |b| |a|))
+ (SETQ |g| (|bfIsVar|))
+ (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|) (NOT (CONSP (CAR |l2|))))
+ (SETQ |l2| (CONS |l2| NIL))))
+ (COND ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|)))
+ (T
+ (|bfAND|
+ (CONS |rev|
+ (|append| |l2|
+ (CONS
+ (LIST 'PROGN
+ (|bfLetForm| |a|
+ (LIST '|reverse!| |a|))
+ 'T)
+ NIL)))))))
+ (T (|bpSpecificErrorHere| "bad IS code is generated") (|bpTrap|))))))
(DEFUN |bfHas| (|expr| |prop|)
- (COND
- ((SYMBOLP |prop|) (LIST 'GET |expr| (|quote| |prop|)))
- (T (|bpSpecificErrorHere| "expected identifier as property name"))))
+ (COND ((SYMBOLP |prop|) (LIST 'GET |expr| (|quote| |prop|)))
+ (T (|bpSpecificErrorHere| "expected identifier as property name"))))
(DEFUN |bfApplication| (|bfop| |bfarg|)
- (COND
- ((|bfTupleP| |bfarg|) (CONS |bfop| (CDR |bfarg|)))
- (T (LIST |bfop| |bfarg|))))
+ (COND ((|bfTupleP| |bfarg|) (CONS |bfop| (CDR |bfarg|)))
+ (T (LIST |bfop| |bfarg|))))
(DEFUN |bfReName| (|x|)
(PROG (|a|)
- (RETURN
- (COND ((SETQ |a| (GET |x| 'SHOERENAME)) (CAR |a|)) (T |x|)))))
+ (RETURN (COND ((SETQ |a| (GET |x| 'SHOERENAME)) (CAR |a|)) (T |x|)))))
(DEFUN |sequence?| (|x| |pred|)
(PROG (|seq| |ISTMP#1|)
(RETURN
- (AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |seq| (CAR |ISTMP#1|)) T)))
- (CONSP |seq|)
- (LET ((|bfVar#2| T) (|bfVar#1| |seq|) (|y| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- (T (SETQ |bfVar#2| (APPLY |pred| |y| NIL))
- (COND ((NOT |bfVar#2|) (RETURN NIL)))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
+ (AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |seq| (CAR |ISTMP#1|)) T)))
+ (CONSP |seq|)
+ (LET ((|bfVar#2| T) (|bfVar#1| |seq|) (|y| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T (SETQ |bfVar#2| (APPLY |pred| |y| NIL))
+ (COND ((NOT |bfVar#2|) (RETURN NIL)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
(DEFUN |idList?| (|x|)
(AND (CONSP |x|) (EQ (CAR |x|) 'LIST)
(LET ((|bfVar#2| T) (|bfVar#1| (CDR |x|)) (|arg| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- (T (SETQ |bfVar#2| (|defQuoteId| |arg|))
- (COND ((NOT |bfVar#2|) (RETURN NIL)))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T (SETQ |bfVar#2| (|defQuoteId| |arg|))
+ (COND ((NOT |bfVar#2|) (RETURN NIL)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))
(DEFUN |charList?| (|x|)
(AND (CONSP |x|) (EQ (CAR |x|) 'LIST)
(LET ((|bfVar#2| T) (|bfVar#1| (CDR |x|)) (|arg| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- (T (SETQ |bfVar#2| (|bfChar?| |arg|))
- (COND ((NOT |bfVar#2|) (RETURN NIL)))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T (SETQ |bfVar#2| (|bfChar?| |arg|))
+ (COND ((NOT |bfVar#2|) (RETURN NIL)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))
(DEFUN |stringList?| (|x|)
(AND (CONSP |x|) (EQ (CAR |x|) 'LIST)
(LET ((|bfVar#2| T) (|bfVar#1| (CDR |x|)) (|arg| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- (T (SETQ |bfVar#2| (|bfString?| |arg|))
- (COND ((NOT |bfVar#2|) (RETURN NIL)))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |arg| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T (SETQ |bfVar#2| (|bfString?| |arg|))
+ (COND ((NOT |bfVar#2|) (RETURN NIL)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))
(DEFUN |bfMember| (|var| |seq|)
(PROG (|y| |x| |ISTMP#2| |ISTMP#1|)
(RETURN
- (COND
- ((OR (INTEGERP |var|) (|sequence?| |seq| #'INTEGERP))
- (COND
- ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
- (PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN
- (SETQ |ISTMP#2| (CAR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
- (LIST 'EQL |var| |x|))
- (T (LIST '|scalarMember?| |var| |seq|))))
- ((OR (|defQuoteId| |var|) (|sequence?| |seq| #'SYMBOLP))
- (COND
- ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
- (PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN
- (SETQ |ISTMP#2| (CAR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
- (LIST 'EQ |var| (|quote| |x|)))
- (T (LIST '|symbolMember?| |var| |seq|))))
- ((|idList?| |seq|)
- (COND
- ((PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))
- (CONS 'EQ (CONS |var| (CDR |seq|))))
- ((AND (SYMBOLP |var|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |x| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |y| (CAR |ISTMP#2|)) T))))))
- (|bfOR| (LIST (LIST 'EQ |var| |x|) (LIST 'EQ |var| |y|))))
- (T (LIST '|symbolMember?| |var| |seq|))))
- ((OR (|bfChar?| |var|) (|sequence?| |seq| #'CHARACTERP))
- (COND
- ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
- (PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN
- (SETQ |ISTMP#2| (CAR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
- (LIST 'CHAR= |var| |x|))
- (T (LIST '|charMember?| |var| |seq|))))
- ((|charList?| |seq|)
- (COND
- ((PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))
- (CONS 'CHAR= (CONS |var| (CDR |seq|))))
- ((AND (SYMBOLP |var|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |x| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |y| (CAR |ISTMP#2|)) T))))))
- (|bfOR| (LIST (LIST 'CHAR= |var| |x|)
- (LIST 'CHAR= |var| |y|))))
- (T (LIST '|charMember?| |var| |seq|))))
- ((OR (|bfString?| |var|) (|sequence?| |seq| #'STRINGP))
- (COND
- ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
- (PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN
- (SETQ |ISTMP#2| (CAR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
- (LIST 'STRING= |var| |x|))
- (T (LIST '|stringMember?| |var| |seq|))))
- ((|stringList?| |seq|)
- (COND
- ((PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))
- (CONS 'STRING= (CONS |var| (CDR |seq|))))
- ((AND (SYMBOLP |var|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |seq|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |x| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |y| (CAR |ISTMP#2|)) T))))))
- (|bfOR| (LIST (LIST 'STRING= |var| |x|)
- (LIST 'STRING= |var| |y|))))
- (T (LIST '|stringMember?| |var| |seq|))))
- (T (LIST 'MEMBER |var| |seq|))))))
+ (COND
+ ((OR (INTEGERP |var|) (|sequence?| |seq| #'INTEGERP))
+ (COND
+ ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
+ (LIST 'EQL |var| |x|))
+ (T (LIST '|scalarMember?| |var| |seq|))))
+ ((OR (|defQuoteId| |var|) (|sequence?| |seq| #'SYMBOLP))
+ (COND
+ ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
+ (LIST 'EQ |var| (|quote| |x|)))
+ (T (LIST '|symbolMember?| |var| |seq|))))
+ ((|idList?| |seq|)
+ (COND
+ ((PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))
+ (CONS 'EQ (CONS |var| (CDR |seq|))))
+ ((AND (SYMBOLP |var|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |x| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |y| (CAR |ISTMP#2|)) T))))))
+ (|bfOR| (LIST (LIST 'EQ |var| |x|) (LIST 'EQ |var| |y|))))
+ (T (LIST '|symbolMember?| |var| |seq|))))
+ ((OR (|bfChar?| |var|) (|sequence?| |seq| #'CHARACTERP))
+ (COND
+ ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
+ (LIST 'CHAR= |var| |x|))
+ (T (LIST '|charMember?| |var| |seq|))))
+ ((|charList?| |seq|)
+ (COND
+ ((PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))
+ (CONS 'CHAR= (CONS |var| (CDR |seq|))))
+ ((AND (SYMBOLP |var|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |x| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |y| (CAR |ISTMP#2|)) T))))))
+ (|bfOR| (LIST (LIST 'CHAR= |var| |x|) (LIST 'CHAR= |var| |y|))))
+ (T (LIST '|charMember?| |var| |seq|))))
+ ((OR (|bfString?| |var|) (|sequence?| |seq| #'STRINGP))
+ (COND
+ ((AND (CONSP |seq|) (EQ (CAR |seq|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
+ (LIST 'STRING= |var| |x|))
+ (T (LIST '|stringMember?| |var| |seq|))))
+ ((|stringList?| |seq|)
+ (COND
+ ((PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))
+ (CONS 'STRING= (CONS |var| (CDR |seq|))))
+ ((AND (SYMBOLP |var|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |seq|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |x| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |y| (CAR |ISTMP#2|)) T))))))
+ (|bfOR| (LIST (LIST 'STRING= |var| |x|) (LIST 'STRING= |var| |y|))))
+ (T (LIST '|stringMember?| |var| |seq|))))
+ (T (LIST 'MEMBER |var| |seq|))))))
(DEFUN |bfInfApplication| (|op| |left| |right|)
- (COND
- ((EQ |op| 'EQUAL) (|bfQ| |left| |right|))
- ((EQ |op| '/=) (|bfNOT| (|bfQ| |left| |right|)))
- ((EQ |op| '>) (|bfLessp| |right| |left|))
- ((EQ |op| '<) (|bfLessp| |left| |right|))
- ((EQ |op| '<=) (|bfNOT| (|bfLessp| |right| |left|)))
- ((EQ |op| '>=) (|bfNOT| (|bfLessp| |left| |right|)))
- ((EQ |op| 'OR) (|bfOR| (LIST |left| |right|)))
- ((EQ |op| 'AND) (|bfAND| (LIST |left| |right|)))
- ((EQ |op| 'IN) (|bfMember| |left| |right|))
- (T (LIST |op| |left| |right|))))
+ (COND ((EQ |op| 'EQUAL) (|bfQ| |left| |right|))
+ ((EQ |op| '/=) (|bfNOT| (|bfQ| |left| |right|)))
+ ((EQ |op| '>) (|bfLessp| |right| |left|))
+ ((EQ |op| '<) (|bfLessp| |left| |right|))
+ ((EQ |op| '<=) (|bfNOT| (|bfLessp| |right| |left|)))
+ ((EQ |op| '>=) (|bfNOT| (|bfLessp| |left| |right|)))
+ ((EQ |op| 'OR) (|bfOR| (LIST |left| |right|)))
+ ((EQ |op| 'AND) (|bfAND| (LIST |left| |right|)))
+ ((EQ |op| 'IN) (|bfMember| |left| |right|))
+ (T (LIST |op| |left| |right|))))
(DEFUN |bfNOT| (|x|)
(PROG (|a| |ISTMP#1|)
(RETURN
- (COND
- ((AND (CONSP |x|) (EQ (CAR |x|) 'NOT)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |a| (CAR |ISTMP#1|)) T))))
- |a|)
- ((AND (CONSP |x|) (EQ (CAR |x|) 'NULL)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |a| (CAR |ISTMP#1|)) T))))
- |a|)
- (T (LIST 'NOT |x|))))))
+ (COND
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'NOT)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |a| (CAR |ISTMP#1|)) T))))
+ |a|)
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'NULL)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |a| (CAR |ISTMP#1|)) T))))
+ |a|)
+ (T (LIST 'NOT |x|))))))
(DEFUN |bfFlatten| (|op| |x|)
- (COND
- ((AND (CONSP |x|) (EQUAL (CAR |x|) |op|)) (CDR |x|))
- (T (LIST |x|))))
+ (COND ((AND (CONSP |x|) (EQUAL (CAR |x|) |op|)) (CDR |x|)) (T (LIST |x|))))
(DEFUN |bfOR| (|l|)
- (COND
- ((NULL |l|) NIL)
- ((NULL (CDR |l|)) (CAR |l|))
- (T (CONS 'OR
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|)
- (|c| NIL))
- (LOOP
- (COND
+ (COND ((NULL |l|) NIL) ((NULL (CDR |l|)) (CAR |l|))
+ (T
+ (CONS 'OR
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|) (|c| NIL))
+ (LOOP
+ (COND
((OR (NOT (CONSP |bfVar#1|))
(PROGN (SETQ |c| (CAR |bfVar#1|)) NIL))
(RETURN |bfVar#2|))
- (T (LET ((|bfVar#4|
- (|copyList| (|bfFlatten| 'OR |c|))))
- (COND
- ((NULL |bfVar#4|) NIL)
- ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|)
- (SETQ |bfVar#3| (|lastNode| |bfVar#2|)))
- (T (RPLACD |bfVar#3| |bfVar#4|)
+ (T
+ (LET ((|bfVar#4| (|copyList| (|bfFlatten| 'OR |c|))))
+ (COND ((NULL |bfVar#4|) NIL)
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|)
+ (SETQ |bfVar#3| (|lastNode| |bfVar#2|)))
+ (T (RPLACD |bfVar#3| |bfVar#4|)
(SETQ |bfVar#3| (|lastNode| |bfVar#3|)))))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
(DEFUN |bfAND| (|l|)
- (COND
- ((NULL |l|) T)
- ((NULL (CDR |l|)) (CAR |l|))
- (T (CONS 'AND
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|)
- (|c| NIL))
- (LOOP
- (COND
+ (COND ((NULL |l|) T) ((NULL (CDR |l|)) (CAR |l|))
+ (T
+ (CONS 'AND
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|) (|c| NIL))
+ (LOOP
+ (COND
((OR (NOT (CONSP |bfVar#1|))
(PROGN (SETQ |c| (CAR |bfVar#1|)) NIL))
(RETURN |bfVar#2|))
- (T (LET ((|bfVar#4|
- (|copyList| (|bfFlatten| 'AND |c|))))
- (COND
- ((NULL |bfVar#4|) NIL)
- ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|)
- (SETQ |bfVar#3| (|lastNode| |bfVar#2|)))
- (T (RPLACD |bfVar#3| |bfVar#4|)
+ (T
+ (LET ((|bfVar#4| (|copyList| (|bfFlatten| 'AND |c|))))
+ (COND ((NULL |bfVar#4|) NIL)
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|)
+ (SETQ |bfVar#3| (|lastNode| |bfVar#2|)))
+ (T (RPLACD |bfVar#3| |bfVar#4|)
(SETQ |bfVar#3| (|lastNode| |bfVar#3|)))))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
(DEFUN |defQuoteId| (|x|)
(AND (CONSP |x|) (EQ (CAR |x|) 'QUOTE) (SYMBOLP (CADR |x|))))
(DEFUN |bfChar?| (|x|)
(OR (CHARACTERP |x|)
- (AND (CONSP |x|)
- (|symbolMember?| (CAR |x|) '(|char| CODE-CHAR SCHAR)))))
+ (AND (CONSP |x|) (|symbolMember?| (CAR |x|) '(|char| CODE-CHAR SCHAR)))))
(DEFUN |bfSmintable| (|x|)
(OR (INTEGERP |x|)
(AND (CONSP |x|)
- (|symbolMember?| (CAR |x|)
- '(SIZE LENGTH CHAR-CODE MAXINDEX + -)))))
+ (|symbolMember?| (CAR |x|) '(SIZE LENGTH CHAR-CODE MAXINDEX + -)))))
(DEFUN |bfString?| (|x|)
(OR (STRINGP |x|)
(AND (CONSP |x|)
- (|symbolMember?| (CAR |x|)
- '(STRING SYMBOL-NAME |subString|)))))
+ (|symbolMember?| (CAR |x|) '(STRING SYMBOL-NAME |subString|)))))
(DEFUN |bfQ| (|l| |r|)
- (COND
- ((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR= |l| |r|))
- ((OR (|bfSmintable| |l|) (|bfSmintable| |r|)) (LIST 'EQL |l| |r|))
- ((OR (|defQuoteId| |l|) (|defQuoteId| |r|)) (LIST 'EQ |l| |r|))
- ((NULL |l|) (LIST 'NULL |r|))
- ((NULL |r|) (LIST 'NULL |l|))
- ((OR (EQ |l| T) (EQ |r| T)) (LIST 'EQ |l| |r|))
- ((OR (|bfString?| |l|) (|bfString?| |r|)) (LIST 'STRING= |l| |r|))
- ((OR (EQ |l| '|%nothing|) (EQ |r| '|%nothing|)) (LIST 'EQ |l| |r|))
- (T (LIST 'EQUAL |l| |r|))))
+ (COND ((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR= |l| |r|))
+ ((OR (|bfSmintable| |l|) (|bfSmintable| |r|)) (LIST 'EQL |l| |r|))
+ ((OR (|defQuoteId| |l|) (|defQuoteId| |r|)) (LIST 'EQ |l| |r|))
+ ((NULL |l|) (LIST 'NULL |r|)) ((NULL |r|) (LIST 'NULL |l|))
+ ((OR (EQ |l| T) (EQ |r| T)) (LIST 'EQ |l| |r|))
+ ((OR (|bfString?| |l|) (|bfString?| |r|)) (LIST 'STRING= |l| |r|))
+ ((OR (EQ |l| '|%nothing|) (EQ |r| '|%nothing|)) (LIST 'EQ |l| |r|))
+ (T (LIST 'EQUAL |l| |r|))))
(DEFUN |bfLessp| (|l| |r|)
- (COND
- ((EQL |l| 0) (LIST 'PLUSP |r|))
- ((EQL |r| 0) (LIST 'MINUSP |l|))
- ((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR< |l| |r|))
- ((OR (|bfString?| |l|) (|bfString?| |r|)) (LIST 'STRING< |l| |r|))
- (T (LIST '< |l| |r|))))
+ (COND ((EQL |l| 0) (LIST 'PLUSP |r|)) ((EQL |r| 0) (LIST 'MINUSP |l|))
+ ((OR (|bfChar?| |l|) (|bfChar?| |r|)) (LIST 'CHAR< |l| |r|))
+ ((OR (|bfString?| |l|) (|bfString?| |r|)) (LIST 'STRING< |l| |r|))
+ (T (LIST '< |l| |r|))))
(DEFUN |bfLambda| (|vars| |body|)
(PROGN
- (SETQ |vars|
- (COND ((|bfTupleP| |vars|) (CDR |vars|)) (T (LIST |vars|))))
- (LIST 'LAMBDA |vars| |body|)))
+ (SETQ |vars| (COND ((|bfTupleP| |vars|) (CDR |vars|)) (T (LIST |vars|))))
+ (LIST 'LAMBDA |vars| |body|)))
(DEFUN |bfMDef| (|op| |args| |body|)
- (PROG (|def| |lamex| |sb2| |sb| |largl| |nargl| |sgargl| |gargl|
- |LETTMP#1| |argl|)
+ (PROG (|def| |lamex| |sb2| |sb| |largl| |nargl| |sgargl| |gargl| |LETTMP#1|
+ |argl|)
(DECLARE (SPECIAL |$wheredefs|))
(RETURN
- (PROGN
- (SETQ |argl|
- (COND
- ((|bfTupleP| |args|) (CDR |args|))
- (T (LIST |args|))))
- (SETQ |LETTMP#1| (|bfGargl| |argl|))
- (SETQ |gargl| (CAR |LETTMP#1|))
- (SETQ |sgargl| (CADR . #0=(|LETTMP#1|)))
- (SETQ |nargl| (CADDR . #0#))
- (SETQ |largl| (CADDDR . #0#))
- (SETQ |sb|
- (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) (|bfVar#1| |nargl|)
- (|i| NIL) (|bfVar#2| |sgargl|) (|j| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)
- (NOT (CONSP |bfVar#2|))
- (PROGN (SETQ |j| (CAR |bfVar#2|)) NIL))
- (RETURN |bfVar#3|))
- ((NULL |bfVar#3|)
- (SETQ |bfVar#3| #1=(CONS (CONS |i| |j|) NIL))
- (SETQ |bfVar#4| |bfVar#3|))
- (T (RPLACD |bfVar#4| #1#)
- (SETQ |bfVar#4| (CDR |bfVar#4|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))
- (SETQ |bfVar#2| (CDR |bfVar#2|)))))
- (SETQ |body| (|applySubst| |sb| |body|))
- (SETQ |sb2|
- (LET ((|bfVar#7| NIL) (|bfVar#8| NIL)
- (|bfVar#5| |sgargl|) (|i| NIL) (|bfVar#6| |largl|)
+ (PROGN
+ (SETQ |argl| (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|))))
+ (SETQ |LETTMP#1| (|bfGargl| |argl|))
+ (SETQ |gargl| (CAR |LETTMP#1|))
+ (SETQ |sgargl| (CADR . #1=(|LETTMP#1|)))
+ (SETQ |nargl| (CADDR . #1#))
+ (SETQ |largl| (CADDDR . #1#))
+ (SETQ |sb|
+ (LET ((|bfVar#3| NIL)
+ (|bfVar#4| NIL)
+ (|bfVar#1| |nargl|)
+ (|i| NIL)
+ (|bfVar#2| |sgargl|)
(|j| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#5|))
- (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL)
- (NOT (CONSP |bfVar#6|))
- (PROGN (SETQ |j| (CAR |bfVar#6|)) NIL))
- (RETURN |bfVar#7|))
- ((NULL |bfVar#7|)
- (SETQ |bfVar#7|
- #2=(CONS (LIST 'CONS (|quote| |i|) |j|) NIL))
- (SETQ |bfVar#8| |bfVar#7|))
- (T (RPLACD |bfVar#8| #2#)
- (SETQ |bfVar#8| (CDR |bfVar#8|))))
- (SETQ |bfVar#5| (CDR |bfVar#5|))
- (SETQ |bfVar#6| (CDR |bfVar#6|)))))
- (SETQ |body|
- (LIST '|applySubst| (CONS 'LIST |sb2|) (|quote| |body|)))
- (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|))
- (SETQ |def| (LIST |op| |lamex|))
- (CONS (|shoeComp| |def|)
- (LET ((|bfVar#10| NIL) (|bfVar#11| NIL)
- (|bfVar#9| |$wheredefs|) (|d| NIL))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL)
+ (NOT (CONSP |bfVar#2|))
+ (PROGN (SETQ |j| (CAR |bfVar#2|)) NIL))
+ (RETURN |bfVar#3|))
+ ((NULL |bfVar#3|)
+ (SETQ |bfVar#3| #2=(CONS (CONS |i| |j|) NIL))
+ (SETQ |bfVar#4| |bfVar#3|))
+ (T (RPLACD |bfVar#4| #2#) (SETQ |bfVar#4| (CDR |bfVar#4|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))
+ (SETQ |bfVar#2| (CDR |bfVar#2|)))))
+ (SETQ |body| (|applySubst| |sb| |body|))
+ (SETQ |sb2|
+ (LET ((|bfVar#7| NIL)
+ (|bfVar#8| NIL)
+ (|bfVar#5| |sgargl|)
+ (|i| NIL)
+ (|bfVar#6| |largl|)
+ (|j| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#9|))
- (PROGN (SETQ |d| (CAR |bfVar#9|)) NIL))
- (RETURN |bfVar#10|))
- (T (LET ((|bfVar#12|
- (|copyList|
- (|shoeComps| (|bfDef1| |d|)))))
- (COND
- ((NULL |bfVar#12|) NIL)
- ((NULL |bfVar#10|)
- (SETQ |bfVar#10| |bfVar#12|)
- (SETQ |bfVar#11| (|lastNode| |bfVar#10|)))
- (T (RPLACD |bfVar#11| |bfVar#12|)
- (SETQ |bfVar#11| (|lastNode| |bfVar#11|)))))))
- (SETQ |bfVar#9| (CDR |bfVar#9|)))))))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#5|))
+ (PROGN (SETQ |i| (CAR |bfVar#5|)) NIL)
+ (NOT (CONSP |bfVar#6|))
+ (PROGN (SETQ |j| (CAR |bfVar#6|)) NIL))
+ (RETURN |bfVar#7|))
+ ((NULL |bfVar#7|)
+ (SETQ |bfVar#7|
+ #3=(CONS (LIST 'CONS (|quote| |i|) |j|) NIL))
+ (SETQ |bfVar#8| |bfVar#7|))
+ (T (RPLACD |bfVar#8| #3#) (SETQ |bfVar#8| (CDR |bfVar#8|))))
+ (SETQ |bfVar#5| (CDR |bfVar#5|))
+ (SETQ |bfVar#6| (CDR |bfVar#6|)))))
+ (SETQ |body| (LIST '|applySubst| (CONS 'LIST |sb2|) (|quote| |body|)))
+ (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|))
+ (SETQ |def| (LIST |op| |lamex|))
+ (CONS (|shoeComp| |def|)
+ (LET ((|bfVar#10| NIL)
+ (|bfVar#11| NIL)
+ (|bfVar#9| |$wheredefs|)
+ (|d| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#9|))
+ (PROGN (SETQ |d| (CAR |bfVar#9|)) NIL))
+ (RETURN |bfVar#10|))
+ (T
+ (LET ((|bfVar#12| (|copyList| (|shoeComps| (|bfDef1| |d|)))))
+ (COND ((NULL |bfVar#12|) NIL)
+ ((NULL |bfVar#10|) (SETQ |bfVar#10| |bfVar#12|)
+ (SETQ |bfVar#11| (|lastNode| |bfVar#10|)))
+ (T (RPLACD |bfVar#11| |bfVar#12|)
+ (SETQ |bfVar#11| (|lastNode| |bfVar#11|)))))))
+ (SETQ |bfVar#9| (CDR |bfVar#9|)))))))))
(DEFUN |bfGargl| (|argl|)
(PROG (|f| |d| |c| |b| |a| |LETTMP#1|)
(RETURN
- (COND
- ((NULL |argl|) (LIST NIL NIL NIL NIL))
- (T (SETQ |LETTMP#1| (|bfGargl| (CDR |argl|)))
- (SETQ |a| (CAR |LETTMP#1|))
- (SETQ |b| (CADR . #0=(|LETTMP#1|))) (SETQ |c| (CADDR . #0#))
- (SETQ |d| (CADDDR . #0#))
- (COND
+ (COND ((NULL |argl|) (LIST NIL NIL NIL NIL))
+ (T (SETQ |LETTMP#1| (|bfGargl| (CDR |argl|)))
+ (SETQ |a| (CAR |LETTMP#1|)) (SETQ |b| (CADR . #1=(|LETTMP#1|)))
+ (SETQ |c| (CADDR . #1#)) (SETQ |d| (CADDDR . #1#))
+ (COND
((EQ (CAR |argl|) '&REST)
(LIST (CONS (CAR |argl|) |b|) |b| |c|
- (CONS (LIST 'CONS (|quote| 'LIST) (CAR |d|))
- (CDR |d|))))
+ (CONS (LIST 'CONS (|quote| 'LIST) (CAR |d|)) (CDR |d|))))
(T (SETQ |f| (|bfGenSymbol|))
- (LIST (CONS |f| |a|) (CONS |f| |b|)
- (CONS (CAR |argl|) |c|) (CONS |f| |d|)))))))))
+ (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|)
+ (CONS |f| |d|)))))))))
(DEFUN |bfDef1| (|bfVar#1|)
- (PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args|
- |op|)
- (RETURN
- (PROGN
- (SETQ |op| (CAR |bfVar#1|))
- (SETQ |args| (CADR . #0=(|bfVar#1|)))
- (SETQ |body| (CADDR . #0#))
- (SETQ |argl|
- (COND
- ((|bfTupleP| |args|) (CDR |args|))
- (T (LIST |args|))))
- (SETQ |LETTMP#1| (|bfInsertLet| |argl| |body|))
- (SETQ |quotes| (CAR |LETTMP#1|))
- (SETQ |control| (CADR . #1=(|LETTMP#1|)))
- (SETQ |arglp| (CADDR . #1#))
- (SETQ |body| (CADDDR . #1#))
- (COND
- (|quotes| (|shoeLAM| |op| |arglp| |control| |body|))
- (T (LIST (LIST |op| (LIST 'LAMBDA |arglp| |body|)))))))))
+ (PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| |op|)
+ (RETURN
+ (PROGN
+ (SETQ |op| (CAR |bfVar#1|))
+ (SETQ |args| (CADR . #1=(|bfVar#1|)))
+ (SETQ |body| (CADDR . #1#))
+ (SETQ |argl| (COND ((|bfTupleP| |args|) (CDR |args|)) (T (LIST |args|))))
+ (SETQ |LETTMP#1| (|bfInsertLet| |argl| |body|))
+ (SETQ |quotes| (CAR |LETTMP#1|))
+ (SETQ |control| (CADR . #2=(|LETTMP#1|)))
+ (SETQ |arglp| (CADDR . #2#))
+ (SETQ |body| (CADDDR . #2#))
+ (COND (|quotes| (|shoeLAM| |op| |arglp| |control| |body|))
+ (T (LIST (LIST |op| (LIST 'LAMBDA |arglp| |body|)))))))))
(DEFUN |shoeLAM| (|op| |args| |control| |body|)
(PROG (|innerfunc| |margs|)
(RETURN
- (PROGN
- (SETQ |margs| (|bfGenSymbol|))
- (SETQ |innerfunc| (INTERN (CONCAT (SYMBOL-NAME |op|) ",LAM")))
- (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|))
- (LIST |op|
- (LIST 'MLAMBDA (LIST '&REST |margs|)
- (LIST 'CONS (|quote| |innerfunc|)
- (LIST 'WRAP |margs|
- (|quote| |control|))))))))))
+ (PROGN
+ (SETQ |margs| (|bfGenSymbol|))
+ (SETQ |innerfunc| (INTERN (CONCAT (SYMBOL-NAME |op|) ",LAM")))
+ (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|))
+ (LIST |op|
+ (LIST 'MLAMBDA (LIST '&REST |margs|)
+ (LIST 'CONS (|quote| |innerfunc|)
+ (LIST 'WRAP |margs| (|quote| |control|))))))))))
(DEFUN |bfDef| (|op| |args| |body|)
(PROG (|body1| |arg1| |op1| |LETTMP#1|)
- (DECLARE (SPECIAL |$wheredefs| |$bfClamming|))
+ (DECLARE (SPECIAL |$bfClamming| |$wheredefs|))
(RETURN
- (COND
- (|$bfClamming|
- (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#2| NIL) (|bfVar#3| NIL)
- (|bfVar#1|
- (CONS (LIST |op| |args| |body|) |$wheredefs|))
- (|d| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- (T (LET ((|bfVar#4|
- (|copyList|
- (|shoeComps| (|bfDef1| |d|)))))
- (COND
- ((NULL |bfVar#4|) NIL)
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2| |bfVar#4|)
- (SETQ |bfVar#3| (|lastNode| |bfVar#2|)))
- (T (RPLACD |bfVar#3| |bfVar#4|)
- (SETQ |bfVar#3| (|lastNode| |bfVar#3|)))))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))))))
+ (COND
+ (|$bfClamming|
+ (SETQ |LETTMP#1|
+ (|shoeComp| (CAR (|bfDef1| (LIST |op| |args| |body|)))))
+ (SETQ |op1| (CADR . #1=(|LETTMP#1|))) (SETQ |arg1| (CADDR . #1#))
+ (SETQ |body1| (CDDDR . #1#)) (|bfCompHash| |op1| |arg1| |body1|))
+ (T
+ (|bfTuple|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| (CONS (LIST |op| |args| |body|) |$wheredefs|))
+ (|d| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T
+ (LET ((|bfVar#4| (|copyList| (|shoeComps| (|bfDef1| |d|)))))
+ (COND ((NULL |bfVar#4|) NIL)
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| |bfVar#4|)
+ (SETQ |bfVar#3| (|lastNode| |bfVar#2|)))
+ (T (RPLACD |bfVar#3| |bfVar#4|)
+ (SETQ |bfVar#3| (|lastNode| |bfVar#3|)))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))))))
(DEFUN |shoeComps| (|x|)
(LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |x|) (|def| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |def| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2| #0=(CONS (|shoeComp| |def|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |def| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (|shoeComp| |def|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
(DEFUN |shoeComp| (|x|)
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (|shoeCompTran| (CADR |x|)))
- (COND
- ((AND (CONSP |a|) (EQ (CAR |a|) 'LAMBDA))
- (CONS 'DEFUN (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|)))))
- (T (CONS 'DEFMACRO
- (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|))))))))))
+ (PROGN
+ (SETQ |a| (|shoeCompTran| (CADR |x|)))
+ (COND
+ ((AND (CONSP |a|) (EQ (CAR |a|) 'LAMBDA))
+ (CONS 'DEFUN (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|)))))
+ (T (CONS 'DEFMACRO (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|))))))))))
(DEFUN |bfParameterList| (|p1| |p2|)
- (COND
- ((AND (NULL |p2|) (CONSP |p1|)) |p1|)
- ((AND (CONSP |p1|) (EQ (CAR |p1|) '&OPTIONAL))
- (COND
- ((NOT (AND (CONSP |p2|) (EQ (CAR |p2|) '&OPTIONAL)))
- (|bpSpecificErrorHere| "default value required"))
- (T (CONS (CAR |p1|) (|append| (CDR |p1|) (CDR |p2|))))))
- ((AND (CONSP |p2|) (EQ (CAR |p2|) '&OPTIONAL))
- (CONS |p1| (CONS (CAR |p2|) (CDR |p2|))))
- (T (CONS |p1| |p2|))))
+ (COND ((AND (NULL |p2|) (CONSP |p1|)) |p1|)
+ ((AND (CONSP |p1|) (EQ (CAR |p1|) '&OPTIONAL))
+ (COND
+ ((NOT (AND (CONSP |p2|) (EQ (CAR |p2|) '&OPTIONAL)))
+ (|bpSpecificErrorHere| "default value required"))
+ (T (CONS (CAR |p1|) (|append| (CDR |p1|) (CDR |p2|))))))
+ ((AND (CONSP |p2|) (EQ (CAR |p2|) '&OPTIONAL))
+ (CONS |p1| (CONS (CAR |p2|) (CDR |p2|))))
+ (T (CONS |p1| |p2|))))
(DEFUN |bfInsertLet| (|x| |body|)
- (PROG (|body2| |name2| |norq1| |b1| |body1| |name1| |norq| |LETTMP#1|
- |b| |a| |ISTMP#1|)
+ (PROG (|body2| |name2| |norq1| |b1| |body1| |name1| |norq| |LETTMP#1| |b| |a|
+ |ISTMP#1|)
(RETURN
- (COND
- ((NULL |x|) (LIST NIL NIL |x| |body|))
- ((AND (CONSP |x|) (EQ (CAR |x|) '&REST)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |a| (CAR |ISTMP#1|)) T))))
- (COND
- ((AND (CONSP |a|) (EQ (CAR |a|) 'QUOTE)
+ (COND ((NULL |x|) (LIST NIL NIL |x| |body|))
+ ((AND (CONSP |x|) (EQ (CAR |x|) '&REST)
(PROGN
- (SETQ |ISTMP#1| (CDR |a|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |b| (CAR |ISTMP#1|)) T))))
- (LIST T 'QUOTE (LIST '&REST |b|) |body|))
- (T (LIST NIL NIL |x| |body|))))
- (T (SETQ |LETTMP#1| (|bfInsertLet1| (CAR |x|) |body|))
- (SETQ |b| (CAR |LETTMP#1|))
- (SETQ |norq| (CADR . #0=(|LETTMP#1|)))
- (SETQ |name1| (CADDR . #0#)) (SETQ |body1| (CADDDR . #0#))
- (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|))
- (SETQ |b1| (CAR |LETTMP#1|))
- (SETQ |norq1| (CADR . #1=(|LETTMP#1|)))
- (SETQ |name2| (CADDR . #1#)) (SETQ |body2| (CADDDR . #1#))
- (LIST (OR |b| |b1|) (CONS |norq| |norq1|)
- (|bfParameterList| |name1| |name2|) |body2|))))))
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |a| (CAR |ISTMP#1|)) T))))
+ (COND
+ ((AND (CONSP |a|) (EQ (CAR |a|) 'QUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |a|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |b| (CAR |ISTMP#1|)) T))))
+ (LIST T 'QUOTE (LIST '&REST |b|) |body|))
+ (T (LIST NIL NIL |x| |body|))))
+ (T (SETQ |LETTMP#1| (|bfInsertLet1| (CAR |x|) |body|))
+ (SETQ |b| (CAR |LETTMP#1|)) (SETQ |norq| (CADR . #1=(|LETTMP#1|)))
+ (SETQ |name1| (CADDR . #1#)) (SETQ |body1| (CADDDR . #1#))
+ (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|))
+ (SETQ |b1| (CAR |LETTMP#1|))
+ (SETQ |norq1| (CADR . #2=(|LETTMP#1|)))
+ (SETQ |name2| (CADDR . #2#)) (SETQ |body2| (CADDDR . #2#))
+ (LIST (OR |b| |b1|) (CONS |norq| |norq1|)
+ (|bfParameterList| |name1| |name2|) |body2|))))))
(DEFUN |bfInsertLet1| (|y| |body|)
(PROG (|g| |b| |r| |ISTMP#2| |l| |ISTMP#1|)
(RETURN
- (COND
- ((AND (CONSP |y|) (EQ (CAR |y|) 'L%T)
- (PROGN
- (SETQ |ISTMP#1| (CDR |y|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |l| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |r| (CAR |ISTMP#2|)) T))))))
- (LIST NIL NIL |l|
- (|bfMKPROGN| (LIST (|bfLET| |r| |l|) |body|))))
- ((SYMBOLP |y|) (LIST NIL NIL |y| |body|))
- ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE)
- (PROGN
- (SETQ |ISTMP#1| (CDR |y|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |b| (CAR |ISTMP#1|)) T))))
- (LIST T 'QUOTE |b| |body|))
- (T (SETQ |g| (|bfGenSymbol|))
- (COND
- ((NOT (CONSP |y|)) (LIST NIL NIL |g| |body|))
- (T (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|))))))))))))
+ (COND
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'L%T)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |y|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |l| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |r| (CAR |ISTMP#2|)) T))))))
+ (LIST NIL NIL |l| (|bfMKPROGN| (LIST (|bfLET| |r| |l|) |body|))))
+ ((SYMBOLP |y|) (LIST NIL NIL |y| |body|))
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |y|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |b| (CAR |ISTMP#1|)) T))))
+ (LIST T 'QUOTE |b| |body|))
+ (T (SETQ |g| (|bfGenSymbol|))
+ (COND ((NOT (CONSP |y|)) (LIST NIL NIL |g| |body|))
+ (T
+ (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|
- |body'| |lvars| |body| |args| |lamtype|)
- (DECLARE (SPECIAL |$typings| |$dollarVars| |$fluidVars| |$locVars|))
- (RETURN
- (PROGN
- (SETQ |lamtype| (CAR |x|))
- (SETQ |args| (CADR . #0=(|x|)))
- (SETQ |body| (CDDR . #0#))
- (SETQ |$fluidVars| NIL)
- (SETQ |$locVars| NIL)
- (SETQ |$dollarVars| NIL)
- (|shoeCompTran1| |body|)
- (SETQ |$locVars|
- (|setDifference|
- (|setDifference| |$locVars| |$fluidVars|)
- (|shoeATOMs| |args|)))
- (SETQ |body|
+ (PROG (|$dollarVars| |$locVars| |$fluidVars| |fvs| |fl| |fvars| |body'|
+ |lvars| |body| |args| |lamtype|)
+ (DECLARE (SPECIAL |$typings| |$dollarVars| |$locVars| |$fluidVars|))
+ (RETURN
+ (PROGN
+ (SETQ |lamtype| (CAR |x|))
+ (SETQ |args| (CADR . #1=(|x|)))
+ (SETQ |body| (CDDR . #1#))
+ (SETQ |$fluidVars| NIL)
+ (SETQ |$locVars| NIL)
+ (SETQ |$dollarVars| NIL)
+ (|shoeCompTran1| |body|)
+ (SETQ |$locVars|
+ (|setDifference| (|setDifference| |$locVars| |$fluidVars|)
+ (|shoeATOMs| |args|)))
+ (SETQ |body|
(PROGN
- (SETQ |lvars| (|append| |$fluidVars| |$locVars|))
- (SETQ |$fluidVars| (UNION |$fluidVars| |$dollarVars|))
- (SETQ |body'| |body|)
- (COND
- (|$typings|
- (SETQ |body'|
- (CONS (CONS 'DECLARE |$typings|) |body'|))))
- (COND
- (|$fluidVars|
- (SETQ |fvars|
- (LIST 'DECLARE
- (CONS 'SPECIAL |$fluidVars|)))
- (SETQ |body'| (CONS |fvars| |body'|))))
- (COND
- ((OR |lvars| (|needsPROG| |body|))
- (|shoePROG| |lvars| |body'|))
- (T |body'|))))
- (SETQ |fl| (|shoeFluids| |args|))
- (SETQ |body|
+ (SETQ |lvars| (|append| |$fluidVars| |$locVars|))
+ (SETQ |$fluidVars| (UNION |$fluidVars| |$dollarVars|))
+ (SETQ |body'| |body|)
+ (COND
+ (|$typings|
+ (SETQ |body'| (CONS (CONS 'DECLARE |$typings|) |body'|))))
+ (COND
+ (|$fluidVars|
+ (SETQ |fvars| (LIST 'DECLARE (CONS 'SPECIAL |$fluidVars|)))
+ (SETQ |body'| (CONS |fvars| |body'|))))
+ (COND
+ ((OR |lvars| (|needsPROG| |body|))
+ (|shoePROG| |lvars| |body'|))
+ (T |body'|))))
+ (SETQ |fl| (|shoeFluids| |args|))
+ (SETQ |body|
(COND
- (|fl| (SETQ |fvs| (LIST 'DECLARE (CONS 'SPECIAL |fl|)))
- (CONS |fvs| |body|))
- (T |body|)))
- (CONS |lamtype| (CONS |args| |body|))))))
+ (|fl| (SETQ |fvs| (LIST 'DECLARE (CONS 'SPECIAL |fl|)))
+ (CONS |fvs| |body|))
+ (T |body|)))
+ (CONS |lamtype| (CONS |args| |body|))))))
(DEFUN |needsPROG| (|body|)
(PROG (|args| |op|)
(RETURN
- (COND
- ((NOT (CONSP |body|)) NIL)
- (T (SETQ |op| (CAR |body|)) (SETQ |args| (CDR |body|))
- (COND
- ((|symbolMember?| |op| '(RETURN RETURN-FROM)) T)
- ((|symbolMember?| |op|
- '(LET PROG LOOP BLOCK DECLARE LAMBDA))
- NIL)
- (T (LET ((|bfVar#2| NIL) (|bfVar#1| |body|) (|t| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- (T (SETQ |bfVar#2| (|needsPROG| |t|))
- (COND (|bfVar#2| (RETURN |bfVar#2|)))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))))))))
+ (COND ((NOT (CONSP |body|)) NIL)
+ (T (SETQ |op| (CAR |body|)) (SETQ |args| (CDR |body|))
+ (COND ((|symbolMember?| |op| '(RETURN RETURN-FROM)) T)
+ ((|symbolMember?| |op|
+ '(LET PROG
+ LOOP
+ BLOCK
+ DECLARE
+ LAMBDA))
+ NIL)
+ (T
+ (LET ((|bfVar#2| NIL) (|bfVar#1| |body|) (|t| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T (SETQ |bfVar#2| (|needsPROG| |t|))
+ (COND (|bfVar#2| (RETURN |bfVar#2|)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))))))))
(DEFUN |shoePROG| (|v| |b|)
(PROG (|blist| |blast| |LETTMP#1|)
(RETURN
- (COND
- ((NULL |b|) (LIST (LIST 'PROG |v|)))
- (T (SETQ |LETTMP#1| (|reverse| |b|))
- (SETQ |blast| (CAR |LETTMP#1|))
- (SETQ |blist| (|reverse!| (CDR |LETTMP#1|)))
- (LIST (CONS 'PROG
- (CONS |v|
- (|append| |blist|
- (CONS (LIST 'RETURN |blast|) NIL))))))))))
+ (COND ((NULL |b|) (LIST (LIST 'PROG |v|)))
+ (T (SETQ |LETTMP#1| (|reverse| |b|)) (SETQ |blast| (CAR |LETTMP#1|))
+ (SETQ |blist| (|reverse!| (CDR |LETTMP#1|)))
+ (LIST
+ (CONS 'PROG
+ (CONS |v|
+ (|append| |blist|
+ (CONS (LIST 'RETURN |blast|) NIL))))))))))
(DEFUN |shoeFluids| (|x|)
- (COND
- ((AND (|ident?| |x|) (|bfBeginsDollar| |x|)) (LIST |x|))
- ((|atomic?| |x|) NIL)
- (T (|append| (|shoeFluids| (CAR |x|)) (|shoeFluids| (CDR |x|))))))
+ (COND ((AND (|ident?| |x|) (|bfBeginsDollar| |x|)) (LIST |x|))
+ ((|atomic?| |x|) NIL)
+ (T (|append| (|shoeFluids| (CAR |x|)) (|shoeFluids| (CDR |x|))))))
(DEFUN |shoeATOMs| (|x|)
- (COND
- ((|ident?| |x|) (LIST |x|))
- ((|atomic?| |x|) NIL)
- (T (|append| (|shoeATOMs| (CAR |x|)) (|shoeATOMs| (CDR |x|))))))
+ (COND ((|ident?| |x|) (LIST |x|)) ((|atomic?| |x|) NIL)
+ (T (|append| (|shoeATOMs| (CAR |x|)) (|shoeATOMs| (CDR |x|))))))
(DEFUN |isDynamicVariable| (|x|)
(PROG (|y|)
- (DECLARE (SPECIAL |$activeNamespace| |$constantIdentifiers|))
+ (DECLARE (SPECIAL |$constantIdentifiers| |$activeNamespace|))
(RETURN
- (COND
- ((AND (SYMBOLP |x|) (|bfBeginsDollar| |x|))
- (COND
- ((|symbolMember?| |x| |$constantIdentifiers|) NIL)
- ((CONSTANTP |x|) NIL)
- ((OR (BOUNDP |x|) (NULL |$activeNamespace|)) T)
- ((SETQ |y|
- (FIND-SYMBOL (SYMBOL-NAME |x|) |$activeNamespace|))
- (NOT (CONSTANTP |y|)))
- (T T)))
- (T NIL)))))
+ (COND
+ ((AND (SYMBOLP |x|) (|bfBeginsDollar| |x|))
+ (COND ((|symbolMember?| |x| |$constantIdentifiers|) NIL)
+ ((CONSTANTP |x|) NIL)
+ ((OR (BOUNDP |x|) (NULL |$activeNamespace|)) T)
+ ((SETQ |y| (FIND-SYMBOL (SYMBOL-NAME |x|) |$activeNamespace|))
+ (NOT (CONSTANTP |y|)))
+ (T T)))
+ (T NIL)))))
(DEFUN |shoeCompTran1| (|x|)
- (PROG (|n| |elts| |newbindings| |r| |ISTMP#2| |l| |zs| |y| |ISTMP#1|
- U)
- (DECLARE (SPECIAL |$fluidVars| |$locVars| |$dollarVars|))
+ (PROG (|n| |elts| |newbindings| |r| |ISTMP#2| |l| |zs| |y| |ISTMP#1| U)
+ (DECLARE (SPECIAL |$dollarVars| |$locVars| |$fluidVars|))
(RETURN
- (COND
- ((NOT (CONSP |x|))
- (COND
- ((AND (|isDynamicVariable| |x|)
- (NOT (|symbolMember?| |x| |$dollarVars|)))
- (SETQ |$dollarVars| (CONS |x| |$dollarVars|))))
- |x|)
- (T (SETQ U (CAR |x|))
- (COND
- ((EQ U 'QUOTE) |x|)
+ (COND
+ ((NOT (CONSP |x|))
+ (COND
+ ((AND (|isDynamicVariable| |x|)
+ (NOT (|symbolMember?| |x| |$dollarVars|)))
+ (SETQ |$dollarVars| (CONS |x| |$dollarVars|))))
+ |x|)
+ (T (SETQ U (CAR |x|))
+ (COND ((EQ U 'QUOTE) |x|)
((AND (CONSP |x|) (EQ (CAR |x|) 'CASE)
(PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |y| (CAR |ISTMP#1|))
- (SETQ |zs| (CDR |ISTMP#1|))
- T))))
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |y| (CAR |ISTMP#1|))
+ (SETQ |zs| (CDR |ISTMP#1|))
+ T))))
(SETF (CADR |x|) (|shoeCompTran1| |y|))
(LOOP
- (COND
- ((NOT |zs|) (RETURN NIL))
- (T (SETF (CADR (CAR |zs|))
- (|shoeCompTran1| (CADR (CAR |zs|))))
- (SETQ |zs| (CDR |zs|)))))
+ (COND ((NOT |zs|) (RETURN NIL))
+ (T
+ (SETF (CADR (CAR |zs|))
+ (|shoeCompTran1| (CADR (CAR |zs|))))
+ (SETQ |zs| (CDR |zs|)))))
|x|)
((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|)
- (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |r| (CAR |ISTMP#2|)) T))))))
- (RPLACA |x| 'SETQ)
- (SETF (CADDR |x|) (|shoeCompTran1| |r|))
+ (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|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |r| (CAR |ISTMP#2|)) T))))))
+ (RPLACA |x| 'SETQ) (SETF (CADDR |x|) (|shoeCompTran1| |r|))
(COND
- ((SYMBOLP |l|)
- (COND
- ((|bfBeginsDollar| |l|)
- (COND
- ((NOT (|symbolMember?| |l| |$dollarVars|))
- (SETQ |$dollarVars| (CONS |l| |$dollarVars|))))
- |x|)
- (T (COND
- ((NOT (|symbolMember?| |l| |$locVars|))
- (SETQ |$locVars| (CONS |l| |$locVars|))))
- |x|)))
- ((AND (CONSP |l|) (EQ (CAR |l|) 'FLUID))
- (COND
- ((NOT (|symbolMember?| (CADR |l|) |$fluidVars|))
- (SETQ |$fluidVars| (CONS (CADR |l|) |$fluidVars|))))
- (RPLACA (CDR |x|) (CADR |l|)) |x|)))
+ ((SYMBOLP |l|)
+ (COND
+ ((|bfBeginsDollar| |l|)
+ (COND
+ ((NOT (|symbolMember?| |l| |$dollarVars|))
+ (SETQ |$dollarVars| (CONS |l| |$dollarVars|))))
+ |x|)
+ (T
+ (COND
+ ((NOT (|symbolMember?| |l| |$locVars|))
+ (SETQ |$locVars| (CONS |l| |$locVars|))))
+ |x|)))
+ ((AND (CONSP |l|) (EQ (CAR |l|) 'FLUID))
+ (COND
+ ((NOT (|symbolMember?| (CADR |l|) |$fluidVars|))
+ (SETQ |$fluidVars| (CONS (CADR |l|) |$fluidVars|))))
+ (RPLACA (CDR |x|) (CADR |l|)) |x|)))
((EQ U '|%Leave|) (RPLACA |x| 'RETURN) |x|)
- ((|symbolMember?| U '(PROG LAMBDA))
- (SETQ |newbindings| NIL)
+ ((|symbolMember?| U '(PROG LAMBDA)) (SETQ |newbindings| NIL)
(LET ((|bfVar#1| (CADR |x|)) (|y| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- ((NOT (|symbolMember?| |y| |$locVars|))
- (IDENTITY
- (PROGN
- (SETQ |$locVars| (CONS |y| |$locVars|))
- (SETQ |newbindings|
- (CONS |y| |newbindings|))))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |y| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ ((NOT (|symbolMember?| |y| |$locVars|))
+ (IDENTITY
+ (PROGN
+ (SETQ |$locVars| (CONS |y| |$locVars|))
+ (SETQ |newbindings| (CONS |y| |newbindings|))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
(RPLACD (CDR |x|) (|shoeCompTran1| (CDDR |x|)))
(SETQ |$locVars|
- (LET ((|bfVar#3| NIL) (|bfVar#4| NIL)
- (|bfVar#2| |$locVars|) (|y| NIL))
- (LOOP
- (COND
+ (LET ((|bfVar#3| NIL)
+ (|bfVar#4| NIL)
+ (|bfVar#2| |$locVars|)
+ (|y| NIL))
+ (LOOP
+ (COND
((OR (NOT (CONSP |bfVar#2|))
(PROGN (SETQ |y| (CAR |bfVar#2|)) NIL))
(RETURN |bfVar#3|))
- (T (AND (NOT (|symbolMember?| |y|
- |newbindings|))
- (COND
- ((NULL |bfVar#3|)
- (SETQ |bfVar#3| #0=(CONS |y| NIL))
- (SETQ |bfVar#4| |bfVar#3|))
- (T (RPLACD |bfVar#4| #0#)
- (SETQ |bfVar#4| (CDR |bfVar#4|)))))))
- (SETQ |bfVar#2| (CDR |bfVar#2|)))))
+ (T
+ (AND (NOT (|symbolMember?| |y| |newbindings|))
+ (COND
+ ((NULL |bfVar#3|)
+ (SETQ |bfVar#3| #1=(CONS |y| NIL))
+ (SETQ |bfVar#4| |bfVar#3|))
+ (T (RPLACD |bfVar#4| #1#)
+ (SETQ |bfVar#4| (CDR |bfVar#4|)))))))
+ (SETQ |bfVar#2| (CDR |bfVar#2|)))))
|x|)
((AND (CONSP |x|) (EQ (CAR |x|) '|vector|)
(PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |elts| (CAR |ISTMP#1|)) T))))
- (RPLACA |x| 'VECTOR)
- (COND
- ((EQ |elts| 'NIL) (RPLACD |x| NIL))
- (T (RPLACD |x| (|shoeCompTran1| (CDR |elts|)))))
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |elts| (CAR |ISTMP#1|)) T))))
+ (COND ((EQ |elts| 'NIL) (RPLACA |x| 'VECTOR) (RPLACD |x| NIL))
+ ((AND (CONSP |elts|) (EQ (CAR |elts|) 'LIST))
+ (RPLACA |x| 'VECTOR)
+ (RPLACD |x| (|shoeCompTran1| (CDR |elts|))))
+ ((NOT (CONSP |elts|))
+ (SETQ |elts| (|shoeCompTran1| |elts|))
+ (RPLACA |x| 'MAKE-ARRAY)
+ (RPLACD |x|
+ (LIST (LIST 'LIST-LENGTH |elts|) :INITIAL-CONTENTS
+ |elts|)))
+ (T (RPLACA |x| 'COERCE)
+ (RPLACD |x|
+ (LIST (|shoeCompTran1| |elts|)
+ (|quote| 'VECTOR)))))
|x|)
((AND (CONSP |x|) (EQ (CAR |x|) '|%Namespace|)
(PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |n| (CAR |ISTMP#1|)) T))))
- (COND
- ((EQ |n| 'DOT) '*PACKAGE*)
- (T (LIST 'FIND-PACKAGE (SYMBOL-NAME |n|)))))
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |n| (CAR |ISTMP#1|)) T))))
+ (COND ((EQ |n| 'DOT) '*PACKAGE*)
+ (T (LIST 'FIND-PACKAGE (SYMBOL-NAME |n|)))))
(T (RPLACA |x| (|shoeCompTran1| (CAR |x|)))
- (RPLACD |x| (|shoeCompTran1| (CDR |x|))) |x|)))))))
+ (RPLACD |x| (|shoeCompTran1| (CDR |x|))) |x|)))))))
(DEFUN |bfTagged| (|a| |b|)
- (DECLARE (SPECIAL |$typings| |$op|))
- (COND
- ((NULL |$op|) (|%Signature| |a| |b|))
- ((SYMBOLP |a|)
- (COND
- ((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL))
- ((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL))
- (T (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) |a|)))
- (T (LIST 'THE |b| |a|))))
+ (DECLARE (SPECIAL |$op| |$typings|))
+ (COND ((NULL |$op|) (|%Signature| |a| |b|))
+ ((SYMBOLP |a|)
+ (COND ((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL))
+ ((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL))
+ (T (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|))
+ |a|)))
+ (T (LIST 'THE |b| |a|))))
(DEFUN |bfAssign| (|l| |r|)
(PROG (|l'|)
(RETURN
- (COND
- ((|bfTupleP| |l|) (|bfSetelt| (CADR |l|) (CDDR |l|) |r|))
- ((AND (CONSP |l|) (EQ (CAR |l|) '|%Place|))
- (SETQ |l'| (CDR |l|)) (LIST 'SETF |l'| |r|))
- (T (|bfLET| |l| |r|))))))
+ (COND ((|bfTupleP| |l|) (|bfSetelt| (CADR |l|) (CDDR |l|) |r|))
+ ((AND (CONSP |l|) (EQ (CAR |l|) '|%Place|)) (SETQ |l'| (CDR |l|))
+ (LIST 'SETF |l'| |r|))
+ (T (|bfLET| |l| |r|))))))
(DEFUN |bfSetelt| (|e| |l| |r|)
- (COND
- ((NULL (CDR |l|)) (|defSETELT| |e| (CAR |l|) |r|))
- (T (|bfSetelt| (|bfElt| |e| (CAR |l|)) (CDR |l|) |r|))))
+ (COND ((NULL (CDR |l|)) (|defSETELT| |e| (CAR |l|) |r|))
+ (T (|bfSetelt| (|bfElt| |e| (CAR |l|)) (CDR |l|) |r|))))
(DEFUN |bfElt| (|expr| |sel|)
(PROG (|y|)
(RETURN
- (PROGN
- (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION)))
- (COND
- (|y| (COND
- ((INTEGERP |y|) (LIST 'ELT |expr| |y|))
- (T (LIST |y| |expr|))))
- (T (LIST 'ELT |expr| |sel|)))))))
+ (PROGN
+ (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION)))
+ (COND
+ (|y|
+ (COND ((INTEGERP |y|) (LIST 'ELT |expr| |y|)) (T (LIST |y| |expr|))))
+ (T (LIST 'ELT |expr| |sel|)))))))
(DEFUN |defSETELT| (|var| |sel| |expr|)
(PROG (|y|)
(RETURN
- (PROGN
- (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION)))
- (COND
- (|y| (COND
- ((INTEGERP |y|)
- (LIST 'SETF (LIST 'ELT |var| |y|) |expr|))
- ((EQ |y| 'CAR) (LIST 'RPLACA |var| |expr|))
- ((EQ |y| 'CDR) (LIST 'RPLACD |var| |expr|))
- (T (LIST 'SETF (LIST |y| |var|) |expr|))))
- (T (LIST 'SETF (LIST 'ELT |var| |sel|) |expr|)))))))
+ (PROGN
+ (SETQ |y| (AND (SYMBOLP |sel|) (GET |sel| 'SHOESELFUNCTION)))
+ (COND
+ (|y|
+ (COND ((INTEGERP |y|) (LIST 'SETF (LIST 'ELT |var| |y|) |expr|))
+ ((EQ |y| 'CAR) (LIST 'RPLACA |var| |expr|))
+ ((EQ |y| 'CDR) (LIST 'RPLACD |var| |expr|))
+ (T (LIST 'SETF (LIST |y| |var|) |expr|))))
+ (T (LIST 'SETF (LIST 'ELT |var| |sel|) |expr|)))))))
(DEFUN |bfIfThenOnly| (|a| |b|)
(PROG (|b1|)
(RETURN
- (PROGN
- (SETQ |b1|
- (COND
- ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|))
- (T (LIST |b|))))
- (LIST 'COND (CONS |a| |b1|))))))
+ (PROGN
+ (SETQ |b1|
+ (COND ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|))
+ (T (LIST |b|))))
+ (LIST 'COND (CONS |a| |b1|))))))
(DEFUN |bfIf| (|a| |b| |c|)
(PROG (|c1| |b1|)
(RETURN
- (PROGN
- (SETQ |b1|
- (COND
- ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|))
- (T (LIST |b|))))
- (COND
- ((AND (CONSP |c|) (EQ (CAR |c|) 'COND))
- (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|))))
- (T (SETQ |c1|
- (COND
- ((AND (CONSP |c|) (EQ (CAR |c|) 'PROGN))
- (CDR |c|))
- (T (LIST |c|))))
- (LIST 'COND (CONS |a| |b1|) (CONS 'T |c1|))))))))
+ (PROGN
+ (SETQ |b1|
+ (COND ((AND (CONSP |b|) (EQ (CAR |b|) 'PROGN)) (CDR |b|))
+ (T (LIST |b|))))
+ (COND
+ ((AND (CONSP |c|) (EQ (CAR |c|) 'COND))
+ (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|))))
+ (T
+ (SETQ |c1|
+ (COND ((AND (CONSP |c|) (EQ (CAR |c|) 'PROGN)) (CDR |c|))
+ (T (LIST |c|))))
+ (LIST 'COND (CONS |a| |b1|) (CONS 'T |c1|))))))))
-(DEFUN |bfExit| (|a| |b|)
- (LIST 'COND (LIST |a| (LIST 'IDENTITY |b|))))
+(DEFUN |bfExit| (|a| |b|) (LIST 'COND (LIST |a| (LIST 'IDENTITY |b|))))
(DEFUN |bfFlattenSeq| (|l|)
(PROG (|xs| |x|)
(RETURN
- (COND
- ((NULL |l|) |l|)
- (T (SETQ |x| (CAR |l|)) (SETQ |xs| (CDR |l|))
- (COND
+ (COND ((NULL |l|) |l|)
+ (T (SETQ |x| (CAR |l|)) (SETQ |xs| (CDR |l|))
+ (COND
((NOT (CONSP |x|))
(COND ((NULL |xs|) |l|) (T (|bfFlattenSeq| |xs|))))
- ((EQ (CAR |x|) 'PROGN)
- (|bfFlattenSeq| (|append| (CDR |x|) |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|)))))
+ (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|)
(RETURN
- (COND
- ((AND (CONSP |x|) (EQ (CAR |x|) 'PROGN)) (SETQ |y| (CDR |x|))
- |y|)
- (T (LIST |x|))))))
+ (COND ((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|)
+ (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|)
- (NULL (CDR |ISTMP#5|))
- (EQ (CAR |ISTMP#5|) 'T)))))))
- (PROGN (SETQ |conds| (CDR |ISTMP#2|)) T)
- (PROGN (SETQ |conds| (|reverse!| |conds|)) T))))
- (CONS (CONS 'AND |conds|)
- (|bfWashCONDBranchBody| (|bfMKPROGN| (LIST |stmt| |b|)))))
- (T (CONS |a| (|bfWashCONDBranchBody| |b|)))))))
+ (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|) (NULL (CDR |ISTMP#5|))
+ (EQ (CAR |ISTMP#5|) 'T)))))))
+ (PROGN (SETQ |conds| (CDR |ISTMP#2|)) T)
+ (PROGN (SETQ |conds| (|reverse!| |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|)
- (RETURN
- (COND
- ((NULL |l|) NIL)
- (T (SETQ |transform|
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |l|)
- (|x| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)
- (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
+ (PROG (|f| |aft| |before| |no| |transform| |b| |ISTMP#5| |ISTMP#4| |ISTMP#3|
+ |a| |ISTMP#2| |ISTMP#1|)
+ (RETURN
+ (COND ((NULL |l|) NIL)
+ (T
+ (SETQ |transform|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |l|)
+ (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL)
+ (NOT
+ (AND (CONSP |x|) (EQ (CAR |x|) 'COND)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
(NULL (CDR |ISTMP#1|))
(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|)
- (NULL (CDR |ISTMP#3|))
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
(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|)
- (NULL
- (CDR |ISTMP#5|))
+ (SETQ |a| (CAR |ISTMP#2|))
+ (SETQ |ISTMP#3|
+ (CDR |ISTMP#2|))
+ (AND (CONSP |ISTMP#3|)
+ (NULL (CDR |ISTMP#3|))
(PROGN
- (SETQ |b|
- (CAR |ISTMP#5|))
- T))))))))))))))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #0=(CONS (|bfAlternative| |a| |b|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
- (SETQ |no| (LENGTH |transform|))
- (SETQ |before| (|bfTake| |no| |l|))
- (SETQ |aft| (|bfDrop| |no| |l|))
- (COND
+ (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|)
+ (NULL
+ (CDR |ISTMP#5|))
+ (PROGN
+ (SETQ |b|
+ (CAR
+ |ISTMP#5|))
+ T))))))))))))))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2|
+ #1=(CONS (|bfAlternative| |a| |b|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (SETQ |no| (LENGTH |transform|))
+ (SETQ |before| (|bfTake| |no| |l|))
+ (SETQ |aft| (|bfDrop| |no| |l|))
+ (COND
((NULL |before|)
(COND
- ((AND (CONSP |l|) (NULL (CDR |l|)))
- (SETQ |f| (CAR |l|))
- (COND
- ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN))
- (|bfSequence| (CDR |f|)))
- (T |f|)))
- (T (|bfMKPROGN|
- (LIST (CAR |l|) (|bfSequence| (CDR |l|)))))))
+ ((AND (CONSP |l|) (NULL (CDR |l|))) (SETQ |f| (CAR |l|))
+ (COND
+ ((AND (CONSP |f|) (EQ (CAR |f|) 'PROGN))
+ (|bfSequence| (CDR |f|)))
+ (T |f|)))
+ (T (|bfMKPROGN| (LIST (CAR |l|) (|bfSequence| (CDR |l|)))))))
((NULL |aft|) (CONS 'COND |transform|))
- (T (CONS 'COND
- (|append| |transform|
- (CONS (|bfAlternative| 'T
- (|bfSequence| |aft|))
- NIL))))))))))
+ (T
+ (CONS 'COND
+ (|append| |transform|
+ (CONS (|bfAlternative| 'T (|bfSequence| |aft|))
+ NIL))))))))))
(DEFUN |bfWhere| (|context| |expr|)
(PROG (|a| |nondefs| |defs| |opassoc| |LETTMP#1|)
(DECLARE (SPECIAL |$wheredefs|))
(RETURN
- (PROGN
- (SETQ |LETTMP#1| (|defSheepAndGoats| |context|))
- (SETQ |opassoc| (CAR |LETTMP#1|))
- (SETQ |defs| (CADR . #0=(|LETTMP#1|)))
- (SETQ |nondefs| (CADDR . #0#))
- (SETQ |a|
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |defs|)
+ (PROGN
+ (SETQ |LETTMP#1| (|defSheepAndGoats| |context|))
+ (SETQ |opassoc| (CAR |LETTMP#1|))
+ (SETQ |defs| (CADR . #1=(|LETTMP#1|)))
+ (SETQ |nondefs| (CADDR . #1#))
+ (SETQ |a|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |defs|)
(|d| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #1=(CONS (LIST (CAR |d|) (CADR |d|)
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |d| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2|
+ #2=(CONS
+ (LIST (CAR |d|) (CADR |d|)
(|bfSUBLIS| |opassoc| (CADDR |d|)))
- NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #1#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
- (SETQ |$wheredefs| (|append| |a| |$wheredefs|))
- (|bfMKPROGN|
- (|bfSUBLIS| |opassoc| (|append!| |nondefs| (LIST |expr|))))))))
+ NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #2#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (SETQ |$wheredefs| (|append| |a| |$wheredefs|))
+ (|bfMKPROGN|
+ (|bfSUBLIS| |opassoc| (|append!| |nondefs| (LIST |expr|))))))))
(DEFUN |bfCompHash| (|op| |argl| |body|)
(PROG (|computeFunction| |auxfn|)
(RETURN
- (PROGN
- (SETQ |auxfn| (INTERN (CONCAT (SYMBOL-NAME |op|) ";")))
- (SETQ |computeFunction|
+ (PROGN
+ (SETQ |auxfn| (INTERN (CONCAT (SYMBOL-NAME |op|) ";")))
+ (SETQ |computeFunction|
(CONS 'DEFUN (CONS |auxfn| (CONS |argl| |body|))))
- (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|)))))))
+ (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|)))))))
(DEFUN |shoeCompileTimeEvaluation| (|x|)
(LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL) |x|))
(DEFUN |bfMain| (|auxfn| |op|)
- (PROG (|defCode| |cacheVector| |cacheCountCode| |cacheResetCode|
- |cacheType| |mainFunction| |codeBody| |thirdPredPair|
- |putCode| |secondPredPair| |getCode| |g2| |cacheName|
- |computeValue| |arg| |g1|)
- (RETURN
- (PROGN
- (SETQ |g1| (|bfGenSymbol|))
- (SETQ |arg| (LIST '&REST |g1|))
- (SETQ |computeValue|
- (LIST 'APPLY (LIST 'FUNCTION |auxfn|) |g1|))
- (SETQ |cacheName| (INTERN (CONCAT (SYMBOL-NAME |op|) ";AL")))
- (SETQ |g2| (|bfGenSymbol|))
- (SETQ |getCode| (LIST 'GETHASH |g1| |cacheName|))
- (SETQ |secondPredPair| (LIST (LIST 'SETQ |g2| |getCode|) |g2|))
- (SETQ |putCode| (LIST 'SETF |getCode| |computeValue|))
- (SETQ |thirdPredPair| (LIST 'T |putCode|))
- (SETQ |codeBody|
+ (PROG (|defCode| |cacheVector| |cacheCountCode| |cacheResetCode| |cacheType|
+ |mainFunction| |codeBody| |thirdPredPair| |putCode| |secondPredPair|
+ |getCode| |g2| |cacheName| |computeValue| |arg| |g1|)
+ (RETURN
+ (PROGN
+ (SETQ |g1| (|bfGenSymbol|))
+ (SETQ |arg| (LIST '&REST |g1|))
+ (SETQ |computeValue| (LIST 'APPLY (LIST 'FUNCTION |auxfn|) |g1|))
+ (SETQ |cacheName| (INTERN (CONCAT (SYMBOL-NAME |op|) ";AL")))
+ (SETQ |g2| (|bfGenSymbol|))
+ (SETQ |getCode| (LIST 'GETHASH |g1| |cacheName|))
+ (SETQ |secondPredPair| (LIST (LIST 'SETQ |g2| |getCode|) |g2|))
+ (SETQ |putCode| (LIST 'SETF |getCode| |computeValue|))
+ (SETQ |thirdPredPair| (LIST 'T |putCode|))
+ (SETQ |codeBody|
(LIST 'PROG (LIST |g2|)
(LIST 'RETURN
(LIST 'COND |secondPredPair| |thirdPredPair|))))
- (SETQ |mainFunction| (LIST 'DEFUN |op| |arg| |codeBody|))
- (SETQ |cacheType| '|hash-table|)
- (SETQ |cacheResetCode|
+ (SETQ |mainFunction| (LIST 'DEFUN |op| |arg| |codeBody|))
+ (SETQ |cacheType| '|hash-table|)
+ (SETQ |cacheResetCode|
(LIST 'SETQ |cacheName|
(LIST 'MAKE-HASHTABLE (|quote| 'UEQUAL))))
- (SETQ |cacheCountCode| (LIST '|hashCount| |cacheName|))
- (SETQ |cacheVector|
+ (SETQ |cacheCountCode| (LIST '|hashCount| |cacheName|))
+ (SETQ |cacheVector|
(LIST |op| |cacheName| |cacheType| |cacheResetCode|
|cacheCountCode|))
- (SETQ |defCode|
+ (SETQ |defCode|
(LIST 'DEFPARAMETER |cacheName|
(LIST 'MAKE-HASHTABLE (|quote| 'UEQUAL))))
- (LIST |defCode| |mainFunction|
- (LIST 'SETF
- (LIST 'GET (|quote| |op|) (|quote| '|cacheInfo|))
- (|quote| |cacheVector|)))))))
+ (LIST |defCode| |mainFunction|
+ (LIST 'SETF (LIST 'GET (|quote| |op|) (|quote| '|cacheInfo|))
+ (|quote| |cacheVector|)))))))
(DEFUN |bfNamespace| (|x|) (LIST '|%Namespace| |x|))
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfNameOnly|))
-(DEFUN |bfNameOnly| (|x|)
- (COND ((EQ |x| '|t|) (LIST 'T)) (T (LIST |x|))))
+(DEFUN |bfNameOnly| (|x|) (COND ((EQ |x| '|t|) (LIST 'T)) (T (LIST |x|))))
-(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) (|%List| |%Form|))
- |bfNameArgs|))
+(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) (|%List| |%Form|)) |bfNameArgs|))
(DEFUN |bfNameArgs| (|x| |y|)
(PROGN
- (SETQ |y|
- (COND
- ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) (CDR |y|))
- (T (LIST |y|))))
- (CONS |x| |y|)))
+ (SETQ |y|
+ (COND ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) (CDR |y|))
+ (T (LIST |y|))))
+ (CONS |x| |y|)))
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Form|) |bfCreateDef|))
(DEFUN |bfCreateDef| (|x|)
(PROG (|a| |f|)
(RETURN
- (COND
- ((AND (CONSP |x|) (NULL (CDR |x|))) (SETQ |f| (CAR |x|))
- (LIST 'DEFCONSTANT |f| (LIST 'LIST (|quote| |f|))))
- (T (SETQ |a|
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL)
- (|bfVar#1| (CDR |x|)) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2| #0=(CONS (|bfGenSymbol|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
- (LIST 'DEFUN (CAR |x|) |a|
- (LIST 'CONS (|quote| (CAR |x|)) (CONS 'LIST |a|))))))))
+ (COND
+ ((AND (CONSP |x|) (NULL (CDR |x|))) (SETQ |f| (CAR |x|))
+ (LIST 'DEFCONSTANT |f| (LIST 'LIST (|quote| |f|))))
+ (T
+ (SETQ |a|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| (CDR |x|))
+ (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2| #1=(CONS (|bfGenSymbol|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (LIST 'DEFUN (CAR |x|) |a|
+ (LIST 'CONS (|quote| (CAR |x|)) (CONS 'LIST |a|))))))))
(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing|) |%Form|) |bfCaseItem|))
@@ -2264,245 +2220,216 @@
(DEFUN |bfCase| (|x| |y|)
(PROG (|body| |g|)
(RETURN
- (PROGN
- (SETQ |g| (COND ((NOT (CONSP |x|)) |x|) (T (|bfGenSymbol|))))
- (SETQ |body|
- (CONS 'CASE
- (CONS (LIST 'CAR |g|) (|bfCaseItems| |g| |y|))))
- (COND
- ((EQ |g| |x|) |body|)
- (T (LIST 'LET (LIST (LIST |g| |x|)) |body|)))))))
+ (PROGN
+ (SETQ |g| (COND ((NOT (CONSP |x|)) |x|) (T (|bfGenSymbol|))))
+ (SETQ |body| (CONS 'CASE (CONS (LIST 'CAR |g|) (|bfCaseItems| |g| |y|))))
+ (COND ((EQ |g| |x|) |body|)
+ (T (LIST 'LET (LIST (LIST |g| |x|)) |body|)))))))
-(DECLAIM (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|))
- (|%List| |%Form|))
- |bfCaseItems|))
+(DECLAIM
+ (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) (|%List| |%Form|))
+ |bfCaseItems|))
(DEFUN |bfCaseItems| (|g| |x|)
(PROG (|j| |ISTMP#1| |i|)
(RETURN
- (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) (|bfVar#2| |x|)
- (|bfVar#1| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#2|))
- (PROGN (SETQ |bfVar#1| (CAR |bfVar#2|)) NIL))
- (RETURN |bfVar#3|))
- (T (AND (CONSP |bfVar#1|)
- (PROGN
- (SETQ |i| (CAR |bfVar#1|))
- (SETQ |ISTMP#1| (CDR |bfVar#1|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |j| (CAR |ISTMP#1|)) T)))
- (COND
- ((NULL |bfVar#3|)
- (SETQ |bfVar#3|
- #0=(CONS (|bfCI| |g| |i| |j|) NIL))
- (SETQ |bfVar#4| |bfVar#3|))
- (T (RPLACD |bfVar#4| #0#)
- (SETQ |bfVar#4| (CDR |bfVar#4|)))))))
- (SETQ |bfVar#2| (CDR |bfVar#2|)))))))
+ (LET ((|bfVar#3| NIL) (|bfVar#4| NIL) (|bfVar#2| |x|) (|bfVar#1| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#2|))
+ (PROGN (SETQ |bfVar#1| (CAR |bfVar#2|)) NIL))
+ (RETURN |bfVar#3|))
+ (T
+ (AND (CONSP |bfVar#1|)
+ (PROGN
+ (SETQ |i| (CAR |bfVar#1|))
+ (SETQ |ISTMP#1| (CDR |bfVar#1|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |j| (CAR |ISTMP#1|)) T)))
+ (COND
+ ((NULL |bfVar#3|)
+ (SETQ |bfVar#3| #1=(CONS (|bfCI| |g| |i| |j|) NIL))
+ (SETQ |bfVar#4| |bfVar#3|))
+ (T (RPLACD |bfVar#4| #1#) (SETQ |bfVar#4| (CDR |bfVar#4|)))))))
+ (SETQ |bfVar#2| (CDR |bfVar#2|)))))))
(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Form|) |bfCI|))
(DEFUN |bfCI| (|g| |x| |y|)
(PROG (|b| |a|)
(RETURN
- (PROGN
- (SETQ |a| (CDR |x|))
- (COND
- ((NULL |a|) (LIST (CAR |x|) |y|))
- (T (SETQ |b|
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL)
- (|bfVar#1| |a|) (|i| NIL) (|j| 1))
- (LOOP
- (COND
+ (PROGN
+ (SETQ |a| (CDR |x|))
+ (COND ((NULL |a|) (LIST (CAR |x|) |y|))
+ (T
+ (SETQ |b|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |a|)
+ (|i| NIL)
+ (|j| 1))
+ (LOOP
+ (COND
((OR (NOT (CONSP |bfVar#1|))
(PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
(RETURN |bfVar#2|))
- (T (AND (NOT (EQ |i| 'DOT))
- (COND
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #0=(CONS
- (LIST |i|
- (|bfCARCDR| |j| |g|))
- NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|)))))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))
- (SETQ |j| (+ |j| 1)))))
- (COND
- ((NULL |b|) (LIST (CAR |x|) |y|))
- (T (LIST (CAR |x|) (LIST 'LET |b| |y|))))))))))
+ (T
+ (AND (NOT (EQ |i| 'DOT))
+ (COND
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2|
+ #1=(CONS
+ (LIST |i| (|bfCARCDR| |j| |g|))
+ NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3| (CDR |bfVar#3|)))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))
+ (SETQ |j| (+ |j| 1)))))
+ (COND ((NULL |b|) (LIST (CAR |x|) |y|))
+ (T (LIST (CAR |x|) (LIST 'LET |b| |y|))))))))))
(DECLAIM (FTYPE (FUNCTION (|%Short| |%Thing|) |%Form|) |bfCARCDR|))
-(DEFUN |bfCARCDR| (|n| |g|)
- (LIST (INTERN (CONCAT "CA" (|bfDs| |n|) "R")) |g|))
+(DEFUN |bfCARCDR| (|n| |g|) (LIST (INTERN (CONCAT "CA" (|bfDs| |n|) "R")) |g|))
(DECLAIM (FTYPE (FUNCTION (|%Short|) |%String|) |bfDs|))
-(DEFUN |bfDs| (|n|)
- (COND ((EQL |n| 0) "") (T (CONCAT "D" (|bfDs| (- |n| 1))))))
+(DEFUN |bfDs| (|n|) (COND ((EQL |n| 0) "") (T (CONCAT "D" (|bfDs| (- |n| 1))))))
-(DEFUN |bfHandlers| (|n| |e| |hs|)
- (|bfHandlers,main| |n| |e| |hs| NIL))
+(DEFUN |bfHandlers| (|n| |e| |hs|) (|bfHandlers,main| |n| |e| |hs| NIL))
(DEFUN |bfHandlers,main| (|n| |e| |hs| |xs|)
- (PROG (|hs'| |s| |ISTMP#6| |t| |ISTMP#5| |v| |ISTMP#4| |ISTMP#3|
- |ISTMP#2| |ISTMP#1|)
+ (PROG (|hs'| |s| |ISTMP#6| |t| |ISTMP#5| |v| |ISTMP#4| |ISTMP#3| |ISTMP#2|
+ |ISTMP#1|)
(RETURN
- (COND
- ((NULL |hs|)
- (CONS 'COND
- (|reverse!| (CONS (LIST T
- (LIST 'THROW
- :OPEN-AXIOM-CATCH-POINT |n|))
- |xs|))))
- ((AND (CONSP |hs|)
- (PROGN
- (SETQ |ISTMP#1| (CAR |hs|))
- (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) '|%Catch|)
- (PROGN
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (PROGN
- (SETQ |ISTMP#3| (CAR |ISTMP#2|))
- (AND (CONSP |ISTMP#3|)
- (EQ (CAR |ISTMP#3|) '|%Signature|)
- (PROGN
- (SETQ |ISTMP#4| (CDR |ISTMP#3|))
- (AND (CONSP |ISTMP#4|)
- (PROGN
- (SETQ |v| (CAR |ISTMP#4|))
- (SETQ |ISTMP#5|
- (CDR |ISTMP#4|))
- (AND (CONSP |ISTMP#5|)
- (NULL (CDR |ISTMP#5|))
- (PROGN
+ (COND
+ ((NULL |hs|)
+ (CONS 'COND
+ (|reverse!|
+ (CONS (LIST T (LIST 'THROW :OPEN-AXIOM-CATCH-POINT |n|)) |xs|))))
+ ((AND (CONSP |hs|)
+ (PROGN
+ (SETQ |ISTMP#1| (CAR |hs|))
+ (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) '|%Catch|)
+ (PROGN
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (PROGN
+ (SETQ |ISTMP#3| (CAR |ISTMP#2|))
+ (AND (CONSP |ISTMP#3|)
+ (EQ (CAR |ISTMP#3|) '|%Signature|)
+ (PROGN
+ (SETQ |ISTMP#4| (CDR |ISTMP#3|))
+ (AND (CONSP |ISTMP#4|)
+ (PROGN
+ (SETQ |v| (CAR |ISTMP#4|))
+ (SETQ |ISTMP#5| (CDR |ISTMP#4|))
+ (AND (CONSP |ISTMP#5|)
+ (NULL (CDR |ISTMP#5|))
+ (PROGN
(SETQ |t| (CAR |ISTMP#5|))
T)))))))
- (PROGN
- (SETQ |ISTMP#6| (CDR |ISTMP#2|))
- (AND (CONSP |ISTMP#6|)
- (NULL (CDR |ISTMP#6|))
- (PROGN
- (SETQ |s| (CAR |ISTMP#6|))
- T))))))))
- (SETQ |hs'| (CDR |hs|))
- (SETQ |t|
- (COND
- ((SYMBOLP |t|) (|quote| (LIST |t|)))
- (T (|quote| |t|))))
- (|bfHandlers,main| |n| |e| |hs'|
- (CONS (LIST (|bfQ| (LIST 'CAR |e|) |t|)
- (LIST 'LET (LIST (LIST |v| (LIST 'CDR |e|)))
- |s|))
- |xs|)))
- (T (|bpTrap|))))))
+ (PROGN
+ (SETQ |ISTMP#6| (CDR |ISTMP#2|))
+ (AND (CONSP |ISTMP#6|) (NULL (CDR |ISTMP#6|))
+ (PROGN (SETQ |s| (CAR |ISTMP#6|)) T))))))))
+ (SETQ |hs'| (CDR |hs|))
+ (SETQ |t| (COND ((SYMBOLP |t|) (|quote| (LIST |t|))) (T (|quote| |t|))))
+ (|bfHandlers,main| |n| |e| |hs'|
+ (CONS
+ (LIST (|bfQ| (LIST 'CAR |e|) |t|)
+ (LIST 'LET (LIST (LIST |v| (LIST 'CDR |e|)))
+ |s|))
+ |xs|)))
+ (T (|bpTrap|))))))
(DEFUN |codeForCatchHandlers| (|g| |e| |cs|)
(PROG (|ehTest|)
(RETURN
- (PROGN
- (SETQ |ehTest|
+ (PROGN
+ (SETQ |ehTest|
(LIST 'AND (LIST 'CONSP |g|)
(|bfQ| (LIST 'CAR |g|) :OPEN-AXIOM-CATCH-POINT)))
- (LIST 'LET
- (LIST (LIST |g|
- (LIST 'CATCH :OPEN-AXIOM-CATCH-POINT |e|)))
- (LIST 'COND
- (LIST |ehTest|
- (|bfHandlers| |g| (LIST 'CDR |g|) |cs|))
- (LIST T |g|)))))))
+ (LIST 'LET (LIST (LIST |g| (LIST 'CATCH :OPEN-AXIOM-CATCH-POINT |e|)))
+ (LIST 'COND (LIST |ehTest| (|bfHandlers| |g| (LIST 'CDR |g|) |cs|))
+ (LIST T |g|)))))))
-(DECLAIM (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) |%Thing|)
- |bfTry|))
+(DECLAIM (FTYPE (FUNCTION (|%Thing| (|%List| |%Form|)) |%Thing|) |bfTry|))
(DEFUN |bfTry| (|e| |cs|)
(PROG (|s| |cs'| |f| |ISTMP#1| |g|)
(RETURN
- (PROGN
- (SETQ |g| (GENSYM))
- (COND
- ((AND (CONSP |cs|)
- (PROGN (SETQ |ISTMP#1| (|reverse| |cs|)) T)
- (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |f| (CAR |ISTMP#1|))
- (SETQ |cs'| (CDR |ISTMP#1|))
- T)
- (PROGN (SETQ |cs'| (|reverse!| |cs'|)) T) (CONSP |f|)
- (EQ (CAR |f|) '|%Finally|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |f|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |s| (CAR |ISTMP#1|)) T))))
- (COND
- ((NULL |cs'|) (LIST 'UNWIND-PROTECT |e| |s|))
- (T (LIST 'UNWIND-PROTECT
- (|codeForCatchHandlers| |g| |e| |cs'|) |s|))))
- (T (|codeForCatchHandlers| |g| |e| |cs|)))))))
+ (PROGN
+ (SETQ |g| (GENSYM))
+ (COND
+ ((AND (CONSP |cs|) (PROGN (SETQ |ISTMP#1| (|reverse| |cs|)) T)
+ (CONSP |ISTMP#1|)
+ (PROGN (SETQ |f| (CAR |ISTMP#1|)) (SETQ |cs'| (CDR |ISTMP#1|)) T)
+ (PROGN (SETQ |cs'| (|reverse!| |cs'|)) T) (CONSP |f|)
+ (EQ (CAR |f|) '|%Finally|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |f|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |s| (CAR |ISTMP#1|)) T))))
+ (COND ((NULL |cs'|) (LIST 'UNWIND-PROTECT |e| |s|))
+ (T
+ (LIST 'UNWIND-PROTECT (|codeForCatchHandlers| |g| |e| |cs'|)
+ |s|))))
+ (T (|codeForCatchHandlers| |g| |e| |cs|)))))))
(DEFUN |bfThrow| (|e|)
(PROG (|x| |t|)
(RETURN
- (PROGN
- (SETQ |t| NIL)
- (SETQ |x| NIL)
- (COND
- ((AND (CONSP |e|) (EQ (CAR |e|) '|%Pretend|))
- (SETQ |t| (CADDR |e|)) (SETQ |x| (CADR |e|)))
- (T (SETQ |t| '|SystemException|) (SETQ |x| |e|)))
- (SETQ |t|
- (COND
- ((SYMBOLP |t|) (|quote| (LIST |t|)))
- (T (|quote| |t|))))
- (LIST 'THROW :OPEN-AXIOM-CATCH-POINT
- (LIST 'CONS :OPEN-AXIOM-CATCH-POINT (LIST 'CONS |t| |x|)))))))
+ (PROGN
+ (SETQ |t| NIL)
+ (SETQ |x| NIL)
+ (COND
+ ((AND (CONSP |e|) (EQ (CAR |e|) '|%Pretend|)) (SETQ |t| (CADDR |e|))
+ (SETQ |x| (CADR |e|)))
+ (T (SETQ |t| '|SystemException|) (SETQ |x| |e|)))
+ (SETQ |t| (COND ((SYMBOLP |t|) (|quote| (LIST |t|))) (T (|quote| |t|))))
+ (LIST 'THROW :OPEN-AXIOM-CATCH-POINT
+ (LIST 'CONS :OPEN-AXIOM-CATCH-POINT (LIST 'CONS |t| |x|)))))))
-(DECLAIM (FTYPE (FUNCTION (|%Form| (|%List| |%Symbol|)) |%Form|)
- |backquote|))
+(DECLAIM (FTYPE (FUNCTION (|%Form| (|%List| |%Symbol|)) |%Form|) |backquote|))
(DEFUN |backquote| (|form| |params|)
- (COND
- ((NULL |params|) (|quote| |form|))
- ((NOT (CONSP |form|))
- (COND
- ((|symbolMember?| |form| |params|) |form|)
- (T (|quote| |form|))))
- (T (CONS 'LIST
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |form|)
- (|t| NIL))
- (LOOP
- (COND
+ (COND ((NULL |params|) (|quote| |form|))
+ ((NOT (CONSP |form|))
+ (COND ((|symbolMember?| |form| |params|) |form|)
+ (T (|quote| |form|))))
+ (T
+ (CONS 'LIST
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |form|)
+ (|t| NIL))
+ (LOOP
+ (COND
((OR (NOT (CONSP |bfVar#1|))
(PROGN (SETQ |t| (CAR |bfVar#1|)) NIL))
(RETURN |bfVar#2|))
((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #0=(CONS (|backquote| |t| |params|) NIL))
+ (SETQ |bfVar#2| #1=(CONS (|backquote| |t| |params|) NIL))
(SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
(DEFUN |genTypeAlias| (|head| |body|)
(PROG (|args| |op|)
(RETURN
- (PROGN
- (SETQ |op| (CAR |head|))
- (SETQ |args| (CDR |head|))
- (LIST 'DEFTYPE |op| |args| (|backquote| |body| |args|))))))
+ (PROGN
+ (SETQ |op| (CAR |head|))
+ (SETQ |args| (CDR |head|))
+ (LIST 'DEFTYPE |op| |args| (|backquote| |body| |args|))))))
(DEFCONSTANT |$NativeSimpleDataTypes|
- '(|char| |byte| |int| |pointer| |int8| |uint8| |int16| |uint16|
- |int32| |uint32| |int64| |uint64| |float| |float32|
- |double| |float64|))
+ '(|char| |byte| |int| |pointer| |int8| |uint8| |int16| |uint16| |int32|
+ |uint32| |int64| |uint64| |float| |float32| |double| |float64|))
(DEFCONSTANT |$NativeSimpleReturnTypes|
- (|append| |$NativeSimpleDataTypes| '(|void| |string|)))
+ (|append| |$NativeSimpleDataTypes| '(|void| |string|)))
(DEFUN |isSimpleNativeType| (|t|)
(|objectMember?| |t| |$NativeSimpleReturnTypes|))
@@ -2521,136 +2448,117 @@
(DEFUN |nativeType| (|t|)
(PROG (|t'|)
(RETURN
- (COND
- ((NULL |t|) |t|)
- ((NOT (CONSP |t|))
- (COND
- ((SETQ |t'|
- (CDR (ASSOC (|coreSymbol| |t|) |$NativeTypeTable|)))
- (SETQ |t'|
- (COND
- ((|%hasFeature| :SBCL)
- (|bfColonColon| 'SB-ALIEN |t'|))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI |t'|))
- (T |t'|)))
- (COND
- ((AND (EQ |t| '|string|) (|%hasFeature| :SBCL))
- (LIST |t'| :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE
- 'BASE-CHAR))
- (T |t'|)))
- ((|symbolMember?| |t| '(|byte| |uint8|))
- (COND
- ((|%hasFeature| :SBCL)
- (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 8))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT8))
- ((OR (|%hasFeature| :ECL) (|%hasFeature| :CLOZURE))
- :UNSIGNED-BYTE)
- (T (|nativeType| '|char|))))
- ((EQ |t| '|int16|)
+ (COND ((NULL |t|) |t|)
+ ((NOT (CONSP |t|))
(COND
- ((|%hasFeature| :SBCL)
- (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 16))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT16))
- ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT16-T))
- :INT16-T)
- ((|%hasFeature| :CLOZURE) :SIGNED-HALFWORD)
- (T (|unknownNativeTypeError| |t|))))
- ((EQ |t| '|uint16|)
- (COND
- ((|%hasFeature| :SBCL)
- (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 16))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT16))
- ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT16-T))
- :UINT16-T)
- ((|%hasFeature| :CLOZURE) :UNSIGNED-HALFWORD)
- (T (|unknownNativeTypeError| |t|))))
- ((EQ |t| '|int32|)
- (COND
- ((|%hasFeature| :SBCL)
- (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 32))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT32))
- ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT32-T))
- :INT32-T)
- ((|%hasFeature| :CLOZURE) :SIGNED-FULLWORD)
- (T (|unknownNativeTypeError| |t|))))
- ((EQ |t| '|uint32|)
- (COND
- ((|%hasFeature| :SBCL)
- (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 32))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT32))
- ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT32-T))
- :UINT32-T)
- ((|%hasFeature| :CLOZURE) :UNSIGNED-FULLWORD)
- (T (|unknownNativeTypeError| |t|))))
- ((EQ |t| '|int64|)
- (COND
- ((|%hasFeature| :SBCL)
- (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 64))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT64))
- ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT64-T))
- :INT64-T)
- ((|%hasFeature| :CLOZURE) :SIGNED-DOUBLEWORD)
- (T (|unknownNativeTypeError| |t|))))
- ((EQ |t| '|uint64|)
- (COND
- ((|%hasFeature| :SBCL)
- (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 64))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT64))
- ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT64-T))
- :UINT64-T)
- ((|%hasFeature| :CLOZURE) :UNSIGNED-DOUBLEWORD)
- (T (|unknownNativeTypeError| |t|))))
- ((EQ |t| '|float32|) (|nativeType| '|float|))
- ((EQ |t| '|float64|) (|nativeType| '|double|))
- ((EQ |t| '|pointer|)
- (COND
- ((|%hasFeature| :GCL) '|fixnum|)
- ((|%hasFeature| :ECL) :POINTER-VOID)
- ((|%hasFeature| :SBCL)
- (LIST '* (|bfColonColon| 'SB-ALIEN 'VOID)))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER))
- ((|%hasFeature| :CLOZURE) :ADDRESS)
- (T (|unknownNativeTypeError| |t|))))
- (T (|unknownNativeTypeError| |t|))))
- ((EQ (CAR |t|) '|buffer|)
- (COND
- ((|%hasFeature| :GCL) 'OBJECT)
- ((|%hasFeature| :ECL) :OBJECT)
- ((|%hasFeature| :SBCL) (LIST '* (|nativeType| (CADR |t|))))
- ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER))
- ((|%hasFeature| :CLOZURE)
- (LIST :* (|nativeType| (CADR |t|))))
- (T (|unknownNativeTypeError| |t|))))
- ((EQ (CAR |t|) '|pointer|) (|nativeType| '|pointer|))
- (T (|unknownNativeTypeError| |t|))))))
+ ((SETQ |t'| (CDR (ASSOC (|coreSymbol| |t|) |$NativeTypeTable|)))
+ (SETQ |t'|
+ (COND
+ ((|%hasFeature| :SBCL) (|bfColonColon| 'SB-ALIEN |t'|))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI |t'|))
+ (T |t'|)))
+ (COND
+ ((AND (EQ |t| '|string|) (|%hasFeature| :SBCL))
+ (LIST |t'| :EXTERNAL-FORMAT :ASCII :ELEMENT-TYPE 'BASE-CHAR))
+ (T |t'|)))
+ ((|symbolMember?| |t| '(|byte| |uint8|))
+ (COND
+ ((|%hasFeature| :SBCL)
+ (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 8))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT8))
+ ((OR (|%hasFeature| :ECL) (|%hasFeature| :CLOZURE))
+ :UNSIGNED-BYTE)
+ (T (|nativeType| '|char|))))
+ ((EQ |t| '|int16|)
+ (COND
+ ((|%hasFeature| :SBCL)
+ (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 16))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT16))
+ ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT16-T)) :INT16-T)
+ ((|%hasFeature| :CLOZURE) :SIGNED-HALFWORD)
+ (T (|unknownNativeTypeError| |t|))))
+ ((EQ |t| '|uint16|)
+ (COND
+ ((|%hasFeature| :SBCL)
+ (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 16))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT16))
+ ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT16-T)) :UINT16-T)
+ ((|%hasFeature| :CLOZURE) :UNSIGNED-HALFWORD)
+ (T (|unknownNativeTypeError| |t|))))
+ ((EQ |t| '|int32|)
+ (COND
+ ((|%hasFeature| :SBCL)
+ (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 32))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT32))
+ ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT32-T)) :INT32-T)
+ ((|%hasFeature| :CLOZURE) :SIGNED-FULLWORD)
+ (T (|unknownNativeTypeError| |t|))))
+ ((EQ |t| '|uint32|)
+ (COND
+ ((|%hasFeature| :SBCL)
+ (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 32))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT32))
+ ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT32-T)) :UINT32-T)
+ ((|%hasFeature| :CLOZURE) :UNSIGNED-FULLWORD)
+ (T (|unknownNativeTypeError| |t|))))
+ ((EQ |t| '|int64|)
+ (COND
+ ((|%hasFeature| :SBCL)
+ (LIST (|bfColonColon| 'SB-ALIEN 'SIGNED) 64))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'INT64))
+ ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT64-T)) :INT64-T)
+ ((|%hasFeature| :CLOZURE) :SIGNED-DOUBLEWORD)
+ (T (|unknownNativeTypeError| |t|))))
+ ((EQ |t| '|uint64|)
+ (COND
+ ((|%hasFeature| :SBCL)
+ (LIST (|bfColonColon| 'SB-ALIEN 'UNSIGNED) 64))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'UINT64))
+ ((AND (|%hasFeature| :ECL) (|%hasFeature| :UINT64-T)) :UINT64-T)
+ ((|%hasFeature| :CLOZURE) :UNSIGNED-DOUBLEWORD)
+ (T (|unknownNativeTypeError| |t|))))
+ ((EQ |t| '|float32|) (|nativeType| '|float|))
+ ((EQ |t| '|float64|) (|nativeType| '|double|))
+ ((EQ |t| '|pointer|)
+ (COND ((|%hasFeature| :GCL) '|fixnum|)
+ ((|%hasFeature| :ECL) :POINTER-VOID)
+ ((|%hasFeature| :SBCL)
+ (LIST '* (|bfColonColon| 'SB-ALIEN 'VOID)))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER))
+ ((|%hasFeature| :CLOZURE) :ADDRESS)
+ (T (|unknownNativeTypeError| |t|))))
+ (T (|unknownNativeTypeError| |t|))))
+ ((EQ (CAR |t|) '|buffer|)
+ (COND ((|%hasFeature| :GCL) 'OBJECT) ((|%hasFeature| :ECL) :OBJECT)
+ ((|%hasFeature| :SBCL) (LIST '* (|nativeType| (CADR |t|))))
+ ((|%hasFeature| :CLISP) (|bfColonColon| 'FFI 'C-POINTER))
+ ((|%hasFeature| :CLOZURE)
+ (LIST :* (|nativeType| (CADR |t|))))
+ (T (|unknownNativeTypeError| |t|))))
+ ((EQ (CAR |t|) '|pointer|) (|nativeType| '|pointer|))
+ (T (|unknownNativeTypeError| |t|))))))
(DEFUN |nativeReturnType| (|t|)
- (COND
- ((|objectMember?| |t| |$NativeSimpleReturnTypes|)
- (|nativeType| |t|))
- (T (|coreError|
- (CONCAT "invalid return type for native function: "
- (PNAME |t|))))))
+ (COND ((|objectMember?| |t| |$NativeSimpleReturnTypes|) (|nativeType| |t|))
+ (T
+ (|coreError|
+ (CONCAT "invalid return type for native function: " (PNAME |t|))))))
(DEFUN |nativeArgumentType| (|t|)
(PROG (|t'| |c| |m|)
(RETURN
- (COND
- ((|objectMember?| |t| |$NativeSimpleDataTypes|)
- (|nativeType| |t|))
- ((EQ |t| '|string|) (|nativeType| |t|))
- ((OR (NOT (CONSP |t|)) (NOT (EQL (LENGTH |t|) 2)))
- (|coreError| "invalid argument type for a native function"))
- (T (SETQ |m| (CAR |t|)) (SETQ |c| (CAADR . #0=(|t|)))
- (SETQ |t'| (CADADR . #0#))
- (COND
- ((NOT (|symbolMember?| |m|
- '(|readonly| |writeonly| |readwrite|)))
+ (COND ((|objectMember?| |t| |$NativeSimpleDataTypes|) (|nativeType| |t|))
+ ((EQ |t| '|string|) (|nativeType| |t|))
+ ((OR (NOT (CONSP |t|)) (NOT (EQL (LENGTH |t|) 2)))
+ (|coreError| "invalid argument type for a native function"))
+ (T (SETQ |m| (CAR |t|)) (SETQ |c| (CAADR . #1=(|t|)))
+ (SETQ |t'| (CADADR . #1#))
+ (COND
+ ((NOT (|symbolMember?| |m| '(|readonly| |writeonly| |readwrite|)))
(|coreError|
- "missing modifier for argument type for a native function"))
+ "missing modifier for argument type for a native function"))
((NOT (|symbolMember?| |c| '(|buffer| |pointer|)))
- (|coreError|
- "expected 'buffer' or 'pointer' type instance"))
+ (|coreError| "expected 'buffer' or 'pointer' type instance"))
((NOT (|objectMember?| |t'| |$NativeSimpleDataTypes|))
(|coreError| "expected simple native data type"))
(T (|nativeType| (CADR |t|)))))))))
@@ -2658,218 +2566,222 @@
(DEFUN |needsStableReference?| (|t|)
(PROG (|m|)
(RETURN
- (AND (CONSP |t|) (PROGN (SETQ |m| (CAR |t|)) T)
- (|symbolMember?| |m| '(|readonly| |writeonly| |readwrite|))))))
+ (AND (CONSP |t|) (PROGN (SETQ |m| (CAR |t|)) T)
+ (|symbolMember?| |m| '(|readonly| |writeonly| |readwrite|))))))
(DEFUN |coerceToNativeType| (|a| |t|)
(PROG (|y| |c|)
(RETURN
- (COND
- ((OR (|%hasFeature| :GCL) (|%hasFeature| :ECL)
- (|%hasFeature| :CLISP) (|%hasFeature| :CLOZURE))
- |a|)
- ((|%hasFeature| :SBCL)
- (COND
- ((NOT (|needsStableReference?| |t|)) |a|)
- (T (SETQ |c| (CAADR . #0=(|t|))) (SETQ |y| (CADADR . #0#))
+ (COND
+ ((OR (|%hasFeature| :GCL) (|%hasFeature| :ECL) (|%hasFeature| :CLISP)
+ (|%hasFeature| :CLOZURE))
+ |a|)
+ ((|%hasFeature| :SBCL)
+ (COND ((NOT (|needsStableReference?| |t|)) |a|)
+ (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"
- (PNAME |c|))))))))
- (T (|fatalError|
- "don't know how to coerce argument for native type"))))))
+ ((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"
+ (PNAME |c|))))))))
+ (T (|fatalError| "don't know how to coerce argument for native type"))))))
(DEFUN |genGCLnativeTranslation| (|op| |s| |t| |op'|)
(PROG (|ccode| |cargs| |cop| |rettype| |argtypes|)
(RETURN
- (PROGN
- (SETQ |argtypes|
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|)
- (|x| NIL))
+ (PROGN
+ (SETQ |argtypes|
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #0=(CONS (|nativeArgumentType| |x|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
- (SETQ |rettype| (|nativeReturnType| |t|))
- (COND
- ((LET ((|bfVar#5| T) (|bfVar#4| (CONS |t| |s|)) (|x| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#4|))
- (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL))
- (RETURN |bfVar#5|))
- (T (SETQ |bfVar#5| (|isSimpleNativeType| |x|))
- (COND ((NOT |bfVar#5|) (RETURN NIL)))))
- (SETQ |bfVar#4| (CDR |bfVar#4|))))
- (LIST (LIST 'DEFENTRY |op| |argtypes|
- (LIST |rettype| (SYMBOL-NAME |op'|)))))
- (T (SETQ |cop| (CONCAT (SYMBOL-NAME |op'|) "_stub"))
- (SETQ |cargs|
- (LET ((|bfVar#14| NIL) (|bfVar#15| NIL)
- (|bfVar#13| (- (LENGTH |s|) 1)) (|i| 0))
- (LOOP
- (COND
- ((> |i| |bfVar#13|) (RETURN |bfVar#14|))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2| #1=(CONS (|nativeArgumentType| |x|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (SETQ |rettype| (|nativeReturnType| |t|))
+ (COND
+ ((LET ((|bfVar#5| T) (|bfVar#4| (CONS |t| |s|)) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#4|))
+ (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL))
+ (RETURN |bfVar#5|))
+ (T (SETQ |bfVar#5| (|isSimpleNativeType| |x|))
+ (COND ((NOT |bfVar#5|) (RETURN NIL)))))
+ (SETQ |bfVar#4| (CDR |bfVar#4|))))
+ (LIST
+ (LIST 'DEFENTRY |op| |argtypes|
+ (LIST |rettype| (SYMBOL-NAME |op'|)))))
+ (T (SETQ |cop| (CONCAT (SYMBOL-NAME |op'|) "_stub"))
+ (SETQ |cargs|
+ (LET ((|bfVar#14| NIL)
+ (|bfVar#15| NIL)
+ (|bfVar#13| (- (LENGTH |s|) 1))
+ (|i| 0))
+ (LOOP
+ (COND ((> |i| |bfVar#13|) (RETURN |bfVar#14|))
((NULL |bfVar#14|)
(SETQ |bfVar#14|
- (CONS (|genGCLnativeTranslation,mkCArgName|
- |i|)
- NIL))
+ (CONS
+ (|genGCLnativeTranslation,mkCArgName| |i|)
+ NIL))
(SETQ |bfVar#15| |bfVar#14|))
- (T (RPLACD |bfVar#15|
- (CONS
- (|genGCLnativeTranslation,mkCArgName|
- |i|)
- NIL))
- (SETQ |bfVar#15| (CDR |bfVar#15|))))
- (SETQ |i| (+ |i| 1)))))
- (SETQ |ccode|
- (LET ((|bfVar#10| "")
- (|bfVar#12|
- (CONS (|genGCLnativeTranslation,gclTypeInC|
- |t|)
- (CONS " "
- (CONS |cop|
- (CONS "("
- (|append|
- (LET
- ((|bfVar#6| NIL)
- (|bfVar#7| NIL) (|x| |s|)
- (|a| |cargs|))
- (LOOP
- (COND
- ((OR (NOT (CONSP |x|))
- (NOT (CONSP |a|)))
- (RETURN |bfVar#6|))
- ((NULL |bfVar#6|)
- (SETQ |bfVar#6|
- (CONS
- (|genGCLnativeTranslation,cparm|
- |x| |a|)
- NIL))
- (SETQ |bfVar#7|
- |bfVar#6|))
- (T
- (RPLACD |bfVar#7|
- (CONS
- (|genGCLnativeTranslation,cparm|
- |x| |a|)
- NIL))
- (SETQ |bfVar#7|
- (CDR |bfVar#7|))))
- (SETQ |x| (CDR |x|))
- (SETQ |a| (CDR |a|))))
- (CONS ") { "
- (CONS
- (COND
- ((NOT (EQ |t| '|void|))
- "return ")
- (T '||))
- (CONS (SYMBOL-NAME |op'|)
- (CONS "("
- (|append|
- (LET
- ((|bfVar#8| NIL)
- (|bfVar#9| NIL) (|x| |s|)
- (|a| |cargs|))
- (LOOP
- (COND
- ((OR
- (NOT (CONSP |x|))
- (NOT (CONSP |a|)))
- (RETURN |bfVar#8|))
- ((NULL |bfVar#8|)
- (SETQ |bfVar#8|
- (CONS
- (|genGCLnativeTranslation,gclArgsInC|
- |x| |a|)
- NIL))
- (SETQ |bfVar#9|
- |bfVar#8|))
- (T
- (RPLACD |bfVar#9|
- (CONS
- (|genGCLnativeTranslation,gclArgsInC|
- |x| |a|)
- NIL))
- (SETQ |bfVar#9|
- (CDR |bfVar#9|))))
- (SETQ |x| (CDR |x|))
- (SETQ |a| (CDR |a|))))
- (CONS "); }" NIL))))))))))))
- (|bfVar#11| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#12|))
- (PROGN
- (SETQ |bfVar#11| (CAR |bfVar#12|))
- NIL))
- (RETURN |bfVar#10|))
- (T (SETQ |bfVar#10|
- (CONCAT |bfVar#10| |bfVar#11|))))
- (SETQ |bfVar#12| (CDR |bfVar#12|)))))
- (LIST (LIST 'CLINES |ccode|)
- (LIST 'DEFENTRY |op| |argtypes|
- (LIST |rettype| |cop|)))))))))
+ (T
+ (RPLACD |bfVar#15|
+ (CONS
+ (|genGCLnativeTranslation,mkCArgName| |i|)
+ NIL))
+ (SETQ |bfVar#15| (CDR |bfVar#15|))))
+ (SETQ |i| (+ |i| 1)))))
+ (SETQ |ccode|
+ (LET ((|bfVar#10| "")
+ (|bfVar#12|
+ (CONS (|genGCLnativeTranslation,gclTypeInC| |t|)
+ (CONS " "
+ (CONS |cop|
+ (CONS "("
+ (|append|
+ (LET ((|bfVar#6| NIL)
+ (|bfVar#7| NIL)
+ (|x| |s|)
+ (|a| |cargs|))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |x|))
+ (NOT (CONSP |a|)))
+ (RETURN |bfVar#6|))
+ ((NULL |bfVar#6|)
+ (SETQ |bfVar#6|
+ (CONS
+ (|genGCLnativeTranslation,cparm|
+ |x| |a|)
+ NIL))
+ (SETQ |bfVar#7|
+ |bfVar#6|))
+ (T
+ (RPLACD |bfVar#7|
+ (CONS
+ (|genGCLnativeTranslation,cparm|
+ |x| |a|)
+ NIL))
+ (SETQ |bfVar#7|
+ (CDR |bfVar#7|))))
+ (SETQ |x| (CDR |x|))
+ (SETQ |a| (CDR |a|))))
+ (CONS ") { "
+ (CONS
+ (COND
+ ((NOT (EQ |t| '|void|))
+ "return ")
+ (T '||))
+ (CONS
+ (SYMBOL-NAME |op'|)
+ (CONS "("
+ (|append|
+ (LET ((|bfVar#8|
+ NIL)
+ (|bfVar#9|
+ NIL)
+ (|x| |s|)
+ (|a|
+ |cargs|))
+ (LOOP
+ (COND
+ ((OR
+ (NOT
+ (CONSP
+ |x|))
+ (NOT
+ (CONSP
+ |a|)))
+ (RETURN
+ |bfVar#8|))
+ ((NULL
+ |bfVar#8|)
+ (SETQ |bfVar#8|
+ (CONS
+ (|genGCLnativeTranslation,gclArgsInC|
+ |x|
+ |a|)
+ NIL))
+ (SETQ |bfVar#9|
+ |bfVar#8|))
+ (T
+ (RPLACD
+ |bfVar#9|
+ (CONS
+ (|genGCLnativeTranslation,gclArgsInC|
+ |x| |a|)
+ NIL))
+ (SETQ |bfVar#9|
+ (CDR
+ |bfVar#9|))))
+ (SETQ |x|
+ (CDR
+ |x|))
+ (SETQ |a|
+ (CDR
+ |a|))))
+ (CONS "); }"
+ NIL))))))))))))
+ (|bfVar#11| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#12|))
+ (PROGN (SETQ |bfVar#11| (CAR |bfVar#12|)) NIL))
+ (RETURN |bfVar#10|))
+ (T (SETQ |bfVar#10| (CONCAT |bfVar#10| |bfVar#11|))))
+ (SETQ |bfVar#12| (CDR |bfVar#12|)))))
+ (LIST (LIST 'CLINES |ccode|)
+ (LIST 'DEFENTRY |op| |argtypes| (LIST |rettype| |cop|)))))))))
(DEFUN |genGCLnativeTranslation,mkCArgName| (|i|)
(CONCAT "x" (WRITE-TO-STRING |i|)))
(DEFUN |genGCLnativeTranslation,cparm| (|x| |a|)
- (CONCAT (|genGCLnativeTranslation,gclTypeInC| (CAR |x|)) " "
- (CAR |a|) (COND ((CDR |x|) ", ") (T ""))))
+ (CONCAT (|genGCLnativeTranslation,gclTypeInC| (CAR |x|)) " " (CAR |a|)
+ (COND ((CDR |x|) ", ") (T ""))))
(DEFUN |genGCLnativeTranslation,gclTypeInC| (|x|)
(PROG (|ISTMP#3| |ISTMP#2| |ISTMP#1|)
(RETURN
- (COND
- ((|objectMember?| |x| |$NativeSimpleDataTypes|)
- (SYMBOL-NAME |x|))
- ((EQ |x| '|void|) "void")
- ((EQ |x| '|string|) "char*")
- ((AND (CONSP |x|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN
- (SETQ |ISTMP#2| (CAR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (EQ (CAR |ISTMP#2|) '|pointer|)
- (PROGN
+ (COND ((|objectMember?| |x| |$NativeSimpleDataTypes|) (SYMBOL-NAME |x|))
+ ((EQ |x| '|void|) "void") ((EQ |x| '|string|) "char*")
+ ((AND (CONSP |x|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (EQ (CAR |ISTMP#2|) '|pointer|)
+ (PROGN
(SETQ |ISTMP#3| (CDR |ISTMP#2|))
(AND (CONSP |ISTMP#3|)
(NULL (CDR |ISTMP#3|)))))))))
- '|fixnum|)
- (T "object")))))
+ '|fixnum|)
+ (T "object")))))
(DEFUN |genGCLnativeTranslation,gclArgInC| (|x| |a|)
(PROG (|y| |c|)
(RETURN
- (COND
- ((|objectMember?| |x| |$NativeSimpleDataTypes|) |a|)
- ((EQ |x| '|string|) |a|)
- (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"))
- (T (|coreError| "unknown argument type"))))))))
+ (COND ((|objectMember?| |x| |$NativeSimpleDataTypes|) |a|)
+ ((EQ |x| '|string|) |a|)
+ (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"))
+ (T (|coreError| "unknown argument type"))))))))
(DEFUN |genGCLnativeTranslation,gclArgsInC| (|x| |a|)
(CONCAT (|genGCLnativeTranslation,gclArgInC| (CAR |x|) (CAR |a|))
@@ -2878,626 +2790,565 @@
(DEFUN |genECLnativeTranslation| (|op| |s| |t| |op'|)
(PROG (|rettype| |argtypes| |args|)
(RETURN
- (PROGN
- (SETQ |args| NIL)
- (SETQ |argtypes| NIL)
- (LET ((|bfVar#1| |s|) (|x| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETQ |argtypes|
- (CONS (|nativeArgumentType| |x|) |argtypes|))
- (SETQ |args| (CONS (GENSYM) |args|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (SETQ |args| (|reverse| |args|))
- (SETQ |rettype| (|nativeReturnType| |t|))
- (LIST (LIST 'DEFUN |op| |args|
- (LIST (|bfColonColon| 'FFI 'C-INLINE) |args|
- (|reverse!| |argtypes|) |rettype|
- (|genECLnativeTranslation,callTemplate| |op'|
- (LENGTH |args|) |s|)
- :ONE-LINER T)))))))
+ (PROGN
+ (SETQ |args| NIL)
+ (SETQ |argtypes| NIL)
+ (LET ((|bfVar#1| |s|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETQ |argtypes| (CONS (|nativeArgumentType| |x|) |argtypes|))
+ (SETQ |args| (CONS (GENSYM) |args|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (SETQ |args| (|reverse| |args|))
+ (SETQ |rettype| (|nativeReturnType| |t|))
+ (LIST
+ (LIST 'DEFUN |op| |args|
+ (LIST (|bfColonColon| 'FFI 'C-INLINE) |args|
+ (|reverse!| |argtypes|) |rettype|
+ (|genECLnativeTranslation,callTemplate| |op'|
+ (LENGTH |args|) |s|)
+ :ONE-LINER T)))))))
(DEFUN |genECLnativeTranslation,callTemplate| (|op| |n| |s|)
(LET ((|bfVar#6| "")
(|bfVar#8|
- (CONS (SYMBOL-NAME |op|)
- (CONS "("
- (|append|
- (LET ((|bfVar#4| NIL) (|bfVar#5| NIL)
- (|bfVar#2| (- |n| 1)) (|i| 0)
- (|bfVar#3| |s|) (|x| NIL))
- (LOOP
- (COND
- ((OR (> |i| |bfVar#2|)
- (NOT (CONSP |bfVar#3|))
- (PROGN
- (SETQ |x| (CAR |bfVar#3|))
- NIL))
- (RETURN |bfVar#4|))
- ((NULL |bfVar#4|)
- (SETQ |bfVar#4|
- (CONS
- (|genECLnativeTranslation,sharpArg|
- |i| |x|)
- NIL))
- (SETQ |bfVar#5| |bfVar#4|))
- (T (RPLACD |bfVar#5|
- (CONS
- (|genECLnativeTranslation,sharpArg|
- |i| |x|)
- NIL))
- (SETQ |bfVar#5| (CDR |bfVar#5|))))
- (SETQ |i| (+ |i| 1))
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (CONS ")" NIL)))))
+ (CONS (SYMBOL-NAME |op|)
+ (CONS "("
+ (|append|
+ (LET ((|bfVar#4| NIL)
+ (|bfVar#5| NIL)
+ (|bfVar#2| (- |n| 1))
+ (|i| 0)
+ (|bfVar#3| |s|)
+ (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (> |i| |bfVar#2|) (NOT (CONSP |bfVar#3|))
+ (PROGN (SETQ |x| (CAR |bfVar#3|)) NIL))
+ (RETURN |bfVar#4|))
+ ((NULL |bfVar#4|)
+ (SETQ |bfVar#4|
+ (CONS
+ (|genECLnativeTranslation,sharpArg| |i|
+ |x|)
+ NIL))
+ (SETQ |bfVar#5| |bfVar#4|))
+ (T
+ (RPLACD |bfVar#5|
+ (CONS
+ (|genECLnativeTranslation,sharpArg| |i|
+ |x|)
+ NIL))
+ (SETQ |bfVar#5| (CDR |bfVar#5|))))
+ (SETQ |i| (+ |i| 1))
+ (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (CONS ")" NIL)))))
(|bfVar#7| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#8|))
- (PROGN (SETQ |bfVar#7| (CAR |bfVar#8|)) NIL))
- (RETURN |bfVar#6|))
- (T (SETQ |bfVar#6| (CONCAT |bfVar#6| |bfVar#7|))))
- (SETQ |bfVar#8| (CDR |bfVar#8|)))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#8|))
+ (PROGN (SETQ |bfVar#7| (CAR |bfVar#8|)) NIL))
+ (RETURN |bfVar#6|))
+ (T (SETQ |bfVar#6| (CONCAT |bfVar#6| |bfVar#7|))))
+ (SETQ |bfVar#8| (CDR |bfVar#8|)))))
(DEFUN |genECLnativeTranslation,sharpArg| (|i| |x|)
(COND
- ((EQL |i| 0)
- (CONCAT "(#0)" (|genECLnativeTranslation,selectDatum| |x|)))
- (T (CONCAT "," "(#" (WRITE-TO-STRING |i|) ")"
- (|genECLnativeTranslation,selectDatum| |x|)))))
+ ((EQL |i| 0) (CONCAT "(#0)" (|genECLnativeTranslation,selectDatum| |x|)))
+ (T
+ (CONCAT "," "(#" (WRITE-TO-STRING |i|) ")"
+ (|genECLnativeTranslation,selectDatum| |x|)))))
(DEFUN |genECLnativeTranslation,selectDatum| (|x|)
(PROG (|y| |c|)
(RETURN
- (COND
- ((|isSimpleNativeType| |x|) "")
- (T (SETQ |c| (CAADR |x|)) (SETQ |y| (CADADR |x|))
- (COND
+ (COND ((|isSimpleNativeType| |x|) "")
+ (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")
- (T "->vector.self.b8")))
- ((EQ |y| '|int|) "->vector.self.fix")
- ((EQ |y| '|float|) "->vector.self.sf")
- ((EQ |y| '|double|) "->vector.self.df")
- (T (|coreError|
- "unknown argument to buffer type constructor"))))
+ ((OR (EQ |y| '|char|) (EQ |y| '|byte|))
+ (COND ((< |$ECLVersionNumber| 90100) "->vector.self.ch")
+ ((EQ |y| '|char|) "->vector.self.i8")
+ (T "->vector.self.b8")))
+ ((EQ |y| '|int|) "->vector.self.fix")
+ ((EQ |y| '|float|) "->vector.self.sf")
+ ((EQ |y| '|double|) "->vector.self.df")
+ (T
+ (|coreError| "unknown argument to buffer type constructor"))))
((EQ |c| '|pointer|) "")
(T (|coreError| "unknown type constructor"))))))))
(DEFUN |genCLISPnativeTranslation| (|op| |s| |t| |op'|)
- (PROG (|forwardingFun| |ISTMP#2| |p| |fixups| |q| |call| |localPairs|
- |y| |x| |ISTMP#1| |a| |foreignDecl| |unstableArgs| |parms|
- |n| |argtypes| |rettype|)
+ (PROG (|forwardingFun| |ISTMP#2| |p| |fixups| |q| |call| |localPairs| |y| |x|
+ |ISTMP#1| |a| |foreignDecl| |unstableArgs| |parms| |n| |argtypes|
+ |rettype|)
(DECLARE (SPECIAL |$foreignsDefsForCLisp|))
(RETURN
- (PROGN
- (SETQ |rettype| (|nativeReturnType| |t|))
- (SETQ |argtypes|
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|)
- (|x| NIL))
+ (PROGN
+ (SETQ |rettype| (|nativeReturnType| |t|))
+ (SETQ |argtypes|
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #0=(CONS (|nativeArgumentType| |x|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
- (SETQ |n| (INTERN (CONCAT (SYMBOL-NAME |op|) "%clisp-hack")))
- (SETQ |parms|
- (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|)
- (|x| NIL))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2| #1=(CONS (|nativeArgumentType| |x|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (SETQ |n| (INTERN (CONCAT (SYMBOL-NAME |op|) "%clisp-hack")))
+ (SETQ |parms|
+ (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|) (|x| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#4|))
- (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL))
- (RETURN |bfVar#5|))
- ((NULL |bfVar#5|)
- (SETQ |bfVar#5| #1=(CONS (GENSYM "parm") NIL))
- (SETQ |bfVar#6| |bfVar#5|))
- (T (RPLACD |bfVar#6| #1#)
- (SETQ |bfVar#6| (CDR |bfVar#6|))))
- (SETQ |bfVar#4| (CDR |bfVar#4|)))))
- (SETQ |unstableArgs| NIL)
- (LET ((|bfVar#7| |parms|) (|p| NIL) (|bfVar#8| |s|) (|x| NIL)
- (|bfVar#9| |argtypes|) (|y| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#7|))
- (PROGN (SETQ |p| (CAR |bfVar#7|)) NIL)
- (NOT (CONSP |bfVar#8|))
- (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL)
- (NOT (CONSP |bfVar#9|))
- (PROGN (SETQ |y| (CAR |bfVar#9|)) NIL))
- (RETURN NIL))
- ((|needsStableReference?| |x|)
- (IDENTITY
- (SETQ |unstableArgs|
- (CONS (CONS |p| (CONS |x| |y|))
- |unstableArgs|)))))
- (SETQ |bfVar#7| (CDR |bfVar#7|))
- (SETQ |bfVar#8| (CDR |bfVar#8|))
- (SETQ |bfVar#9| (CDR |bfVar#9|))))
- (SETQ |foreignDecl|
+ (COND
+ ((OR (NOT (CONSP |bfVar#4|))
+ (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL))
+ (RETURN |bfVar#5|))
+ ((NULL |bfVar#5|)
+ (SETQ |bfVar#5| #2=(CONS (GENSYM "parm") NIL))
+ (SETQ |bfVar#6| |bfVar#5|))
+ (T (RPLACD |bfVar#6| #2#) (SETQ |bfVar#6| (CDR |bfVar#6|))))
+ (SETQ |bfVar#4| (CDR |bfVar#4|)))))
+ (SETQ |unstableArgs| NIL)
+ (LET ((|bfVar#7| |parms|)
+ (|p| NIL)
+ (|bfVar#8| |s|)
+ (|x| NIL)
+ (|bfVar#9| |argtypes|)
+ (|y| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#7|)) (PROGN (SETQ |p| (CAR |bfVar#7|)) NIL)
+ (NOT (CONSP |bfVar#8|)) (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL)
+ (NOT (CONSP |bfVar#9|)) (PROGN (SETQ |y| (CAR |bfVar#9|)) NIL))
+ (RETURN NIL))
+ ((|needsStableReference?| |x|)
+ (IDENTITY
+ (SETQ |unstableArgs|
+ (CONS (CONS |p| (CONS |x| |y|)) |unstableArgs|)))))
+ (SETQ |bfVar#7| (CDR |bfVar#7|))
+ (SETQ |bfVar#8| (CDR |bfVar#8|))
+ (SETQ |bfVar#9| (CDR |bfVar#9|))))
+ (SETQ |foreignDecl|
(LIST (|bfColonColon| 'FFI 'DEF-CALL-OUT) |n|
(LIST :NAME (SYMBOL-NAME |op'|))
(CONS :ARGUMENTS
- (LET ((|bfVar#12| NIL) (|bfVar#13| NIL)
- (|bfVar#10| |argtypes|) (|x| NIL)
- (|bfVar#11| |parms|) (|a| NIL))
+ (LET ((|bfVar#12| NIL)
+ (|bfVar#13| NIL)
+ (|bfVar#10| |argtypes|)
+ (|x| NIL)
+ (|bfVar#11| |parms|)
+ (|a| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#10|))
- (PROGN
- (SETQ |x| (CAR |bfVar#10|))
- NIL)
- (NOT (CONSP |bfVar#11|))
- (PROGN
- (SETQ |a| (CAR |bfVar#11|))
- NIL))
- (RETURN |bfVar#12|))
- ((NULL |bfVar#12|)
- (SETQ |bfVar#12|
- #2=(CONS (LIST |a| |x|) NIL))
- (SETQ |bfVar#13| |bfVar#12|))
- (T (RPLACD |bfVar#13| #2#)
- (SETQ |bfVar#13| (CDR |bfVar#13|))))
- (SETQ |bfVar#10| (CDR |bfVar#10|))
- (SETQ |bfVar#11| (CDR |bfVar#11|)))))
- (LIST :RETURN-TYPE |rettype|)
- (LIST :LANGUAGE :STDC)))
- (SETQ |forwardingFun|
- (COND
- ((NULL |unstableArgs|)
- (LIST 'DEFUN |op| |parms| (CONS |n| |parms|)))
- (T (SETQ |localPairs|
- (LET ((|bfVar#16| NIL) (|bfVar#17| NIL)
- (|bfVar#15| |unstableArgs|)
- (|bfVar#14| NIL))
- (LOOP
(COND
- ((OR (NOT (CONSP |bfVar#15|))
- (PROGN
- (SETQ |bfVar#14|
- (CAR |bfVar#15|))
- NIL))
- (RETURN |bfVar#16|))
- (T (AND (CONSP |bfVar#14|)
- (PROGN
- (SETQ |a| (CAR |bfVar#14|))
- (SETQ |ISTMP#1|
- (CDR |bfVar#14|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |x| (CAR |ISTMP#1|))
- (SETQ |y| (CDR |ISTMP#1|))
- T)))
- (COND
- ((NULL |bfVar#16|)
- (SETQ |bfVar#16|
- #3=(CONS
- (CONS |a|
- (CONS |x|
- (CONS |y|
- (GENSYM "loc"))))
- NIL))
- (SETQ |bfVar#17| |bfVar#16|))
- (T (RPLACD |bfVar#17| #3#)
- (SETQ |bfVar#17|
- (CDR |bfVar#17|)))))))
- (SETQ |bfVar#15| (CDR |bfVar#15|)))))
- (SETQ |call|
- (CONS |n|
- (LET ((|bfVar#19| NIL) (|bfVar#20| NIL)
- (|bfVar#18| |parms|) (|p| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#18|))
- (PROGN
- (SETQ |p| (CAR |bfVar#18|))
- NIL))
- (RETURN |bfVar#19|))
- ((NULL |bfVar#19|)
- (SETQ |bfVar#19|
- (CONS
- (|genCLISPnativeTranslation,actualArg|
- |p| |localPairs|)
- NIL))
- (SETQ |bfVar#20| |bfVar#19|))
- (T
- (RPLACD |bfVar#20|
- (CONS
- (|genCLISPnativeTranslation,actualArg|
- |p| |localPairs|)
- NIL))
- (SETQ |bfVar#20|
- (CDR |bfVar#20|))))
- (SETQ |bfVar#18| (CDR |bfVar#18|))))))
- (SETQ |call|
- (PROGN
- (SETQ |fixups|
+ ((OR (NOT (CONSP |bfVar#10|))
+ (PROGN (SETQ |x| (CAR |bfVar#10|)) NIL)
+ (NOT (CONSP |bfVar#11|))
+ (PROGN (SETQ |a| (CAR |bfVar#11|)) NIL))
+ (RETURN |bfVar#12|))
+ ((NULL |bfVar#12|)
+ (SETQ |bfVar#12| #3=(CONS (LIST |a| |x|) NIL))
+ (SETQ |bfVar#13| |bfVar#12|))
+ (T (RPLACD |bfVar#13| #3#)
+ (SETQ |bfVar#13| (CDR |bfVar#13|))))
+ (SETQ |bfVar#10| (CDR |bfVar#10|))
+ (SETQ |bfVar#11| (CDR |bfVar#11|)))))
+ (LIST :RETURN-TYPE |rettype|) (LIST :LANGUAGE :STDC)))
+ (SETQ |forwardingFun|
+ (COND
+ ((NULL |unstableArgs|)
+ (LIST 'DEFUN |op| |parms| (CONS |n| |parms|)))
+ (T
+ (SETQ |localPairs|
+ (LET ((|bfVar#16| NIL)
+ (|bfVar#17| NIL)
+ (|bfVar#15| |unstableArgs|)
+ (|bfVar#14| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#15|))
+ (PROGN
+ (SETQ |bfVar#14| (CAR |bfVar#15|))
+ NIL))
+ (RETURN |bfVar#16|))
+ (T
+ (AND (CONSP |bfVar#14|)
+ (PROGN
+ (SETQ |a| (CAR |bfVar#14|))
+ (SETQ |ISTMP#1| (CDR |bfVar#14|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |x| (CAR |ISTMP#1|))
+ (SETQ |y| (CDR |ISTMP#1|))
+ T)))
+ (COND
+ ((NULL |bfVar#16|)
+ (SETQ |bfVar#16|
+ #4=(CONS
+ (CONS |a|
+ (CONS |x|
+ (CONS |y|
+ (GENSYM
+ "loc"))))
+ NIL))
+ (SETQ |bfVar#17| |bfVar#16|))
+ (T (RPLACD |bfVar#17| #4#)
+ (SETQ |bfVar#17| (CDR |bfVar#17|)))))))
+ (SETQ |bfVar#15| (CDR |bfVar#15|)))))
+ (SETQ |call|
+ (CONS |n|
+ (LET ((|bfVar#19| NIL)
+ (|bfVar#20| NIL)
+ (|bfVar#18| |parms|)
+ (|p| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#18|))
+ (PROGN (SETQ |p| (CAR |bfVar#18|)) NIL))
+ (RETURN |bfVar#19|))
+ ((NULL |bfVar#19|)
+ (SETQ |bfVar#19|
+ (CONS
+ (|genCLISPnativeTranslation,actualArg|
+ |p| |localPairs|)
+ NIL))
+ (SETQ |bfVar#20| |bfVar#19|))
+ (T
+ (RPLACD |bfVar#20|
+ (CONS
+ (|genCLISPnativeTranslation,actualArg|
+ |p| |localPairs|)
+ NIL))
+ (SETQ |bfVar#20| (CDR |bfVar#20|))))
+ (SETQ |bfVar#18| (CDR |bfVar#18|))))))
+ (SETQ |call|
+ (PROGN
+ (SETQ |fixups|
(LET ((|bfVar#22| NIL)
(|bfVar#23| NIL)
(|bfVar#21| |localPairs|)
(|p| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#21|))
- (PROGN
+ (COND
+ ((OR (NOT (CONSP |bfVar#21|))
+ (PROGN
(SETQ |p| (CAR |bfVar#21|))
NIL))
- (RETURN |bfVar#22|))
- (T
- (AND
- (NOT
- (NULL
- (SETQ |q|
- (|genCLISPnativeTranslation,copyBack|
- |p|))))
- (COND
- ((NULL |bfVar#22|)
- (SETQ |bfVar#22|
- (CONS |q| NIL))
- (SETQ |bfVar#23|
- |bfVar#22|))
- (T
- (RPLACD |bfVar#23|
- (CONS |q| NIL))
- (SETQ |bfVar#23|
- (CDR |bfVar#23|)))))))
- (SETQ |bfVar#21| (CDR |bfVar#21|)))))
- (COND
- ((NULL |fixups|) (LIST |call|))
- (T (LIST (CONS 'PROG1
- (CONS |call| |fixups|)))))))
- (LET ((|bfVar#25| |localPairs|) (|bfVar#24| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#25|))
- (PROGN
- (SETQ |bfVar#24| (CAR |bfVar#25|))
- NIL))
- (RETURN NIL))
- (T (AND (CONSP |bfVar#24|)
- (PROGN
- (SETQ |p| (CAR |bfVar#24|))
- (SETQ |ISTMP#1| (CDR |bfVar#24|))
- (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|))
- T)))))
- (SETQ |call|
- (LIST
- (CONS
- (|bfColonColon| 'FFI
- 'WITH-FOREIGN-OBJECT)
- (CONS
- (LIST |a|
+ (RETURN |bfVar#22|))
+ (T
+ (AND
+ (NOT
+ (NULL
+ (SETQ |q|
+ (|genCLISPnativeTranslation,copyBack|
+ |p|))))
+ (COND
+ ((NULL |bfVar#22|)
+ (SETQ |bfVar#22| (CONS |q| NIL))
+ (SETQ |bfVar#23| |bfVar#22|))
+ (T (RPLACD |bfVar#23| (CONS |q| NIL))
+ (SETQ |bfVar#23|
+ (CDR |bfVar#23|)))))))
+ (SETQ |bfVar#21| (CDR |bfVar#21|)))))
+ (COND ((NULL |fixups|) (LIST |call|))
+ (T
+ (LIST (CONS 'PROG1 (CONS |call| |fixups|)))))))
+ (LET ((|bfVar#25| |localPairs|) (|bfVar#24| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#25|))
+ (PROGN (SETQ |bfVar#24| (CAR |bfVar#25|)) NIL))
+ (RETURN NIL))
+ (T
+ (AND (CONSP |bfVar#24|)
+ (PROGN
+ (SETQ |p| (CAR |bfVar#24|))
+ (SETQ |ISTMP#1| (CDR |bfVar#24|))
+ (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|))
+ T)))))
+ (SETQ |call|
+ (LIST
+ (CONS
+ (|bfColonColon| 'FFI 'WITH-FOREIGN-OBJECT)
+ (CONS
+ (LIST |a|
(LIST 'FUNCALL
- (LIST 'INTERN
- "getCLISPType" "BOOTTRAN")
- |p|)
+ (LIST 'INTERN "getCLISPType"
+ "BOOTTRAN")
+ |p|)
|p|)
- |call|)))))))
- (SETQ |bfVar#25| (CDR |bfVar#25|))))
- (CONS 'DEFUN (CONS |op| (CONS |parms| |call|))))))
- (SETQ |$foreignsDefsForCLisp|
+ |call|)))))))
+ (SETQ |bfVar#25| (CDR |bfVar#25|))))
+ (CONS 'DEFUN (CONS |op| (CONS |parms| |call|))))))
+ (SETQ |$foreignsDefsForCLisp|
(CONS |foreignDecl| |$foreignsDefsForCLisp|))
- (LIST |forwardingFun|)))))
+ (LIST |forwardingFun|)))))
(DEFUN |genCLISPnativeTranslation,copyBack| (|bfVar#26|)
(PROG (|a| |y| |x| |p|)
(RETURN
- (PROGN
- (SETQ |p| (CAR |bfVar#26|))
- (SETQ |x| (CADR . #0=(|bfVar#26|)))
- (SETQ |y| (CADDR . #0#))
- (SETQ |a| (CDDDR . #0#))
- (COND
- ((AND (CONSP |x|) (EQ (CAR |x|) '|readonly|)) NIL)
- (T (LIST 'SETF |p|
+ (PROGN
+ (SETQ |p| (CAR |bfVar#26|))
+ (SETQ |x| (CADR . #1=(|bfVar#26|)))
+ (SETQ |y| (CADDR . #1#))
+ (SETQ |a| (CDDDR . #1#))
+ (COND ((AND (CONSP |x|) (EQ (CAR |x|) '|readonly|)) NIL)
+ (T
+ (LIST 'SETF |p|
(LIST (|bfColonColon| 'FFI 'FOREIGN-VALUE) |a|))))))))
(DEFUN |genCLISPnativeTranslation,actualArg| (|p| |pairs|)
(PROG (|a'|)
(RETURN
- (COND
- ((SETQ |a'| (CDR (ASSOC |p| |pairs|))) (CDR (CDR |a'|)))
- (T |p|)))))
+ (COND ((SETQ |a'| (CDR (ASSOC |p| |pairs|))) (CDR (CDR |a'|))) (T |p|)))))
-(DEFUN |getCLISPType| (|a|)
- (LIST (|bfColonColon| 'FFI 'C-ARRAY) (LENGTH |a|)))
+(DEFUN |getCLISPType| (|a|) (LIST (|bfColonColon| 'FFI 'C-ARRAY) (LENGTH |a|)))
(DEFUN |genSBCLnativeTranslation| (|op| |s| |t| |op'|)
(PROG (|newArgs| |unstableArgs| |args| |argtypes| |rettype|)
(RETURN
- (PROGN
- (SETQ |rettype| (|nativeReturnType| |t|))
- (SETQ |argtypes|
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|)
- (|x| NIL))
+ (PROGN
+ (SETQ |rettype| (|nativeReturnType| |t|))
+ (SETQ |argtypes|
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #0=(CONS (|nativeArgumentType| |x|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
- (SETQ |args|
- (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|)
- (|x| NIL))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2| #1=(CONS (|nativeArgumentType| |x|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (SETQ |args|
+ (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|) (|x| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#4|))
- (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL))
- (RETURN |bfVar#5|))
- ((NULL |bfVar#5|)
- (SETQ |bfVar#5| #1=(CONS (GENSYM) NIL))
- (SETQ |bfVar#6| |bfVar#5|))
- (T (RPLACD |bfVar#6| #1#)
- (SETQ |bfVar#6| (CDR |bfVar#6|))))
- (SETQ |bfVar#4| (CDR |bfVar#4|)))))
- (SETQ |unstableArgs| NIL)
- (SETQ |newArgs| NIL)
- (LET ((|bfVar#7| |args|) (|a| NIL) (|bfVar#8| |s|) (|x| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#7|))
- (PROGN (SETQ |a| (CAR |bfVar#7|)) NIL)
- (NOT (CONSP |bfVar#8|))
- (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL))
- (RETURN NIL))
- (T (SETQ |newArgs|
- (CONS (|coerceToNativeType| |a| |x|) |newArgs|))
(COND
- ((|needsStableReference?| |x|)
- (SETQ |unstableArgs| (CONS |a| |unstableArgs|))))))
- (SETQ |bfVar#7| (CDR |bfVar#7|))
- (SETQ |bfVar#8| (CDR |bfVar#8|))))
- (SETQ |op'|
- (COND
- ((|%hasFeature| :WIN32)
- (CONCAT "_" (SYMBOL-NAME |op'|)))
- (T (SYMBOL-NAME |op'|))))
- (COND
- ((NULL |unstableArgs|)
- (LIST (LIST 'DEFUN |op| |args|
- (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN")
- (CONS (LIST
- (INTERN "EXTERN-ALIEN" "SB-ALIEN")
- |op'|
- (CONS 'FUNCTION
- (CONS |rettype| |argtypes|)))
- |args|)))))
- (T (LIST (LIST 'DEFUN |op| |args|
- (LIST (|bfColonColon| 'SB-SYS
- 'WITH-PINNED-OBJECTS)
- (|reverse!| |unstableArgs|)
- (CONS (INTERN "ALIEN-FUNCALL"
- "SB-ALIEN")
- (CONS
- (LIST
- (INTERN "EXTERN-ALIEN"
- "SB-ALIEN")
- |op'|
- (CONS 'FUNCTION
- (CONS |rettype| |argtypes|)))
- (|reverse!| |newArgs|))))))))))))
+ ((OR (NOT (CONSP |bfVar#4|))
+ (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL))
+ (RETURN |bfVar#5|))
+ ((NULL |bfVar#5|) (SETQ |bfVar#5| #2=(CONS (GENSYM) NIL))
+ (SETQ |bfVar#6| |bfVar#5|))
+ (T (RPLACD |bfVar#6| #2#) (SETQ |bfVar#6| (CDR |bfVar#6|))))
+ (SETQ |bfVar#4| (CDR |bfVar#4|)))))
+ (SETQ |unstableArgs| NIL)
+ (SETQ |newArgs| NIL)
+ (LET ((|bfVar#7| |args|) (|a| NIL) (|bfVar#8| |s|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#7|)) (PROGN (SETQ |a| (CAR |bfVar#7|)) NIL)
+ (NOT (CONSP |bfVar#8|)) (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL))
+ (RETURN NIL))
+ (T (SETQ |newArgs| (CONS (|coerceToNativeType| |a| |x|) |newArgs|))
+ (COND
+ ((|needsStableReference?| |x|)
+ (SETQ |unstableArgs| (CONS |a| |unstableArgs|))))))
+ (SETQ |bfVar#7| (CDR |bfVar#7|))
+ (SETQ |bfVar#8| (CDR |bfVar#8|))))
+ (SETQ |op'|
+ (COND ((|%hasFeature| :WIN32) (CONCAT "_" (SYMBOL-NAME |op'|)))
+ (T (SYMBOL-NAME |op'|))))
+ (COND
+ ((NULL |unstableArgs|)
+ (LIST
+ (LIST 'DEFUN |op| |args|
+ (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN")
+ (CONS
+ (LIST (INTERN "EXTERN-ALIEN" "SB-ALIEN") |op'|
+ (CONS 'FUNCTION (CONS |rettype| |argtypes|)))
+ |args|)))))
+ (T
+ (LIST
+ (LIST 'DEFUN |op| |args|
+ (LIST (|bfColonColon| 'SB-SYS 'WITH-PINNED-OBJECTS)
+ (|reverse!| |unstableArgs|)
+ (CONS (INTERN "ALIEN-FUNCALL" "SB-ALIEN")
+ (CONS
+ (LIST (INTERN "EXTERN-ALIEN" "SB-ALIEN") |op'|
+ (CONS 'FUNCTION (CONS |rettype| |argtypes|)))
+ (|reverse!| |newArgs|))))))))))))
(DEFUN |genCLOZUREnativeTranslation| (|op| |s| |t| |op'|)
- (PROG (|call| |p'| |ISTMP#3| |ISTMP#2| |ISTMP#1| |aryPairs|
- |strPairs| |parms| |argtypes| |rettype|)
- (RETURN
- (PROGN
- (SETQ |rettype| (|nativeReturnType| |t|))
- (SETQ |argtypes|
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|)
- (|x| NIL))
+ (PROG (|call| |p'| |ISTMP#3| |ISTMP#2| |ISTMP#1| |aryPairs| |strPairs|
+ |parms| |argtypes| |rettype|)
+ (RETURN
+ (PROGN
+ (SETQ |rettype| (|nativeReturnType| |t|))
+ (SETQ |argtypes|
+ (LET ((|bfVar#2| NIL) (|bfVar#3| NIL) (|bfVar#1| |s|) (|x| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #0=(CONS (|nativeArgumentType| |x|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
- (SETQ |parms|
- (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|)
- (|x| NIL))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |x| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2| #1=(CONS (|nativeArgumentType| |x|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (SETQ |parms|
+ (LET ((|bfVar#5| NIL) (|bfVar#6| NIL) (|bfVar#4| |s|) (|x| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#4|))
- (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL))
- (RETURN |bfVar#5|))
- ((NULL |bfVar#5|)
- (SETQ |bfVar#5| #1=(CONS (GENSYM "parm") NIL))
- (SETQ |bfVar#6| |bfVar#5|))
- (T (RPLACD |bfVar#6| #1#)
- (SETQ |bfVar#6| (CDR |bfVar#6|))))
- (SETQ |bfVar#4| (CDR |bfVar#4|)))))
- (SETQ |strPairs| NIL)
- (SETQ |aryPairs| NIL)
- (LET ((|bfVar#7| |parms|) (|p| NIL) (|bfVar#8| |s|) (|x| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#7|))
- (PROGN (SETQ |p| (CAR |bfVar#7|)) NIL)
- (NOT (CONSP |bfVar#8|))
- (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL))
- (RETURN NIL))
- ((EQ |x| '|string|)
- (SETQ |strPairs|
- (CONS (CONS |p| (GENSYM "loc")) |strPairs|)))
- ((AND (CONSP |x|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN
- (SETQ |ISTMP#2| (CAR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (EQ (CAR |ISTMP#2|) '|buffer|)
- (PROGN
- (SETQ |ISTMP#3| (CDR |ISTMP#2|))
- (AND (CONSP |ISTMP#3|)
- (NULL (CDR |ISTMP#3|)))))))))
- (SETQ |aryPairs|
- (CONS (CONS |p| (GENSYM "loc")) |aryPairs|))))
- (SETQ |bfVar#7| (CDR |bfVar#7|))
- (SETQ |bfVar#8| (CDR |bfVar#8|))))
- (COND
- ((|%hasFeature| :DARWIN) (SETQ |op'| (CONCAT "_" |op'|))))
- (SETQ |call|
+ (COND
+ ((OR (NOT (CONSP |bfVar#4|))
+ (PROGN (SETQ |x| (CAR |bfVar#4|)) NIL))
+ (RETURN |bfVar#5|))
+ ((NULL |bfVar#5|)
+ (SETQ |bfVar#5| #2=(CONS (GENSYM "parm") NIL))
+ (SETQ |bfVar#6| |bfVar#5|))
+ (T (RPLACD |bfVar#6| #2#) (SETQ |bfVar#6| (CDR |bfVar#6|))))
+ (SETQ |bfVar#4| (CDR |bfVar#4|)))))
+ (SETQ |strPairs| NIL)
+ (SETQ |aryPairs| NIL)
+ (LET ((|bfVar#7| |parms|) (|p| NIL) (|bfVar#8| |s|) (|x| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#7|)) (PROGN (SETQ |p| (CAR |bfVar#7|)) NIL)
+ (NOT (CONSP |bfVar#8|)) (PROGN (SETQ |x| (CAR |bfVar#8|)) NIL))
+ (RETURN NIL))
+ ((EQ |x| '|string|)
+ (SETQ |strPairs| (CONS (CONS |p| (GENSYM "loc")) |strPairs|)))
+ ((AND (CONSP |x|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN
+ (SETQ |ISTMP#2| (CAR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (EQ (CAR |ISTMP#2|) '|buffer|)
+ (PROGN
+ (SETQ |ISTMP#3| (CDR |ISTMP#2|))
+ (AND (CONSP |ISTMP#3|)
+ (NULL (CDR |ISTMP#3|)))))))))
+ (SETQ |aryPairs| (CONS (CONS |p| (GENSYM "loc")) |aryPairs|))))
+ (SETQ |bfVar#7| (CDR |bfVar#7|))
+ (SETQ |bfVar#8| (CDR |bfVar#8|))))
+ (COND ((|%hasFeature| :DARWIN) (SETQ |op'| (CONCAT "_" |op'|))))
+ (SETQ |call|
(CONS (|bfColonColon| 'CCL 'EXTERNAL-CALL)
(CONS (STRING |op'|)
(|append|
- (LET ((|bfVar#11| NIL) (|bfVar#12| NIL)
- (|bfVar#9| |argtypes|) (|x| NIL)
- (|bfVar#10| |parms|) (|p| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#9|))
- (PROGN
- (SETQ |x| (CAR |bfVar#9|))
- NIL)
- (NOT (CONSP |bfVar#10|))
- (PROGN
- (SETQ |p| (CAR |bfVar#10|))
- NIL))
- (RETURN |bfVar#11|))
- (T
- (LET
- ((|bfVar#13|
- (LIST |x|
- (COND
- ((SETQ |p'|
- (ASSOC |p| |strPairs|))
- (CDR |p'|))
- ((SETQ |p'|
- (ASSOC |p| |aryPairs|))
- (CDR |p'|))
- (T |p|)))))
- (COND
- ((NULL |bfVar#13|) NIL)
- ((NULL |bfVar#11|)
- (SETQ |bfVar#11| |bfVar#13|)
- (SETQ |bfVar#12|
- (|lastNode| |bfVar#11|)))
- (T
- (RPLACD |bfVar#12|
- |bfVar#13|)
- (SETQ |bfVar#12|
- (|lastNode| |bfVar#12|)))))))
- (SETQ |bfVar#9| (CDR |bfVar#9|))
- (SETQ |bfVar#10| (CDR |bfVar#10|))))
- (CONS |rettype| NIL)))))
- (COND
- ((EQ |t| '|string|)
+ (LET ((|bfVar#11| NIL)
+ (|bfVar#12| NIL)
+ (|bfVar#9| |argtypes|)
+ (|x| NIL)
+ (|bfVar#10| |parms|)
+ (|p| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#9|))
+ (PROGN (SETQ |x| (CAR |bfVar#9|)) NIL)
+ (NOT (CONSP |bfVar#10|))
+ (PROGN (SETQ |p| (CAR |bfVar#10|)) NIL))
+ (RETURN |bfVar#11|))
+ (T
+ (LET ((|bfVar#13|
+ (LIST |x|
+ (COND
+ ((SETQ |p'|
+ (ASSOC |p| |strPairs|))
+ (CDR |p'|))
+ ((SETQ |p'|
+ (ASSOC |p| |aryPairs|))
+ (CDR |p'|))
+ (T |p|)))))
+ (COND ((NULL |bfVar#13|) NIL)
+ ((NULL |bfVar#11|)
+ (SETQ |bfVar#11| |bfVar#13|)
+ (SETQ |bfVar#12|
+ (|lastNode| |bfVar#11|)))
+ (T (RPLACD |bfVar#12| |bfVar#13|)
+ (SETQ |bfVar#12|
+ (|lastNode| |bfVar#12|)))))))
+ (SETQ |bfVar#9| (CDR |bfVar#9|))
+ (SETQ |bfVar#10| (CDR |bfVar#10|))))
+ (CONS |rettype| NIL)))))
+ (COND
+ ((EQ |t| '|string|)
+ (SETQ |call| (LIST (|bfColonColon| 'CCL 'GET-CSTRING) |call|))))
+ (LET ((|bfVar#14| |aryPairs|) (|arg| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#14|))
+ (PROGN (SETQ |arg| (CAR |bfVar#14|)) NIL))
+ (RETURN NIL))
+ (T
(SETQ |call|
- (LIST (|bfColonColon| 'CCL 'GET-CSTRING) |call|))))
- (LET ((|bfVar#14| |aryPairs|) (|arg| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#14|))
- (PROGN (SETQ |arg| (CAR |bfVar#14|)) NIL))
- (RETURN NIL))
- (T (SETQ |call|
- (LIST (|bfColonColon| 'CCL
- 'WITH-POINTER-TO-IVECTOR)
- (LIST (CDR |arg|) (CAR |arg|)) |call|))))
- (SETQ |bfVar#14| (CDR |bfVar#14|))))
- (COND
- (|strPairs| (SETQ |call|
- (LIST (|bfColonColon| 'CCL 'WITH-CSTRS)
- (LET ((|bfVar#16| NIL)
- (|bfVar#17| NIL)
- (|bfVar#15| |strPairs|)
- (|arg| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#15|))
- (PROGN
- (SETQ |arg|
- (CAR |bfVar#15|))
+ (LIST (|bfColonColon| 'CCL 'WITH-POINTER-TO-IVECTOR)
+ (LIST (CDR |arg|) (CAR |arg|)) |call|))))
+ (SETQ |bfVar#14| (CDR |bfVar#14|))))
+ (COND
+ (|strPairs|
+ (SETQ |call|
+ (LIST (|bfColonColon| 'CCL 'WITH-CSTRS)
+ (LET ((|bfVar#16| NIL)
+ (|bfVar#17| NIL)
+ (|bfVar#15| |strPairs|)
+ (|arg| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#15|))
+ (PROGN (SETQ |arg| (CAR |bfVar#15|)) NIL))
+ (RETURN |bfVar#16|))
+ ((NULL |bfVar#16|)
+ (SETQ |bfVar#16|
+ #3=(CONS (LIST (CDR |arg|) (CAR |arg|))
NIL))
- (RETURN |bfVar#16|))
- ((NULL |bfVar#16|)
- (SETQ |bfVar#16|
- #2=(CONS
- (LIST (CDR |arg|)
- (CAR |arg|))
- NIL))
- (SETQ |bfVar#17| |bfVar#16|))
- (T (RPLACD |bfVar#17| #2#)
- (SETQ |bfVar#17|
- (CDR |bfVar#17|))))
- (SETQ |bfVar#15|
- (CDR |bfVar#15|))))
- |call|))))
- (LIST (LIST 'DEFUN |op| |parms| |call|))))))
+ (SETQ |bfVar#17| |bfVar#16|))
+ (T (RPLACD |bfVar#17| #3#)
+ (SETQ |bfVar#17| (CDR |bfVar#17|))))
+ (SETQ |bfVar#15| (CDR |bfVar#15|))))
+ |call|))))
+ (LIST (LIST 'DEFUN |op| |parms| |call|))))))
(DEFUN |genImportDeclaration| (|op| |sig|)
(PROG (|s| |t| |m| |ISTMP#2| |op'| |ISTMP#1|)
(RETURN
- (COND
- ((NOT (AND (CONSP |sig|) (EQ (CAR |sig|) '|%Signature|)
+ (COND
+ ((NOT
+ (AND (CONSP |sig|) (EQ (CAR |sig|) '|%Signature|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |sig|))
+ (AND (CONSP |ISTMP#1|)
(PROGN
- (SETQ |ISTMP#1| (CDR |sig|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |op'| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |m| (CAR |ISTMP#2|)) T)))))))
- (|coreError| "invalid signature"))
- ((NOT (AND (CONSP |m|) (EQ (CAR |m|) '|%Mapping|)
+ (SETQ |op'| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |m| (CAR |ISTMP#2|)) T)))))))
+ (|coreError| "invalid signature"))
+ ((NOT
+ (AND (CONSP |m|) (EQ (CAR |m|) '|%Mapping|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |m|))
+ (AND (CONSP |ISTMP#1|)
(PROGN
- (SETQ |ISTMP#1| (CDR |m|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |t| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |s| (CAR |ISTMP#2|)) T)))))))
- (|coreError| "invalid function type"))
- (T (COND ((AND |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'|))
- ((|%hasFeature| :CLOZURE)
- (|genCLOZUREnativeTranslation| |op| |s| |t| |op'|))
- (T (|fatalError|
- "import declaration not implemented for this Lisp"))))))))
+ (SETQ |t| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |s| (CAR |ISTMP#2|)) T)))))))
+ (|coreError| "invalid function type"))
+ (T (COND ((AND |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'|))
+ ((|%hasFeature| :CLOZURE)
+ (|genCLOZUREnativeTranslation| |op| |s| |t| |op'|))
+ (T
+ (|fatalError|
+ "import declaration not implemented for this Lisp"))))))))
diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp
index 531e84ed..61c7e369 100644
--- a/src/boot/strap/includer.clisp
+++ b/src/boot/strap/includer.clisp
@@ -6,23 +6,20 @@
(PROVIDE "includer")
(DEFUN PNAME (|x|)
- (COND
- ((SYMBOLP |x|) (SYMBOL-NAME |x|))
- ((CHARACTERP |x|) (STRING |x|))
- (T NIL)))
+ (COND ((SYMBOLP |x|) (SYMBOL-NAME |x|)) ((CHARACTERP |x|) (STRING |x|))
+ (T NIL)))
-(DEFUN |shoeNotFound| (|fn|)
- (PROGN (|coreError| (LIST |fn| " not found")) NIL))
+(DEFUN |shoeNotFound| (|fn|) (PROGN (|coreError| (LIST |fn| " not found")) NIL))
(DEFUN |shoeReadLispString| (|s| |n|)
(PROG (|l|)
(RETURN
- (PROGN
- (SETQ |l| (LENGTH |s|))
- (COND
- ((NOT (< |n| |l|)) NIL)
- (T (READ-FROM-STRING
- (CONCAT "(" (|subString| |s| |n| (- |l| |n|)) ")"))))))))
+ (PROGN
+ (SETQ |l| (LENGTH |s|))
+ (COND ((NOT (< |n| |l|)) NIL)
+ (T
+ (READ-FROM-STRING
+ (CONCAT "(" (|subString| |s| |n| (- |l| |n|)) ")"))))))))
(DEFUN |shoeConsole| (|line|) (WRITE-LINE |line| *TERMINAL-IO*))
@@ -31,25 +28,22 @@
(DEFUN |diagnosticLocation| (|tok|)
(PROG (|pos|)
(RETURN
- (PROGN
- (SETQ |pos| (|shoeTokPosn| |tok|))
- (CONCAT "line " (WRITE-TO-STRING (|lineNo| |pos|)) ", column "
- (WRITE-TO-STRING (|lineCharacter| |pos|)))))))
+ (PROGN
+ (SETQ |pos| (|shoeTokPosn| |tok|))
+ (CONCAT "line " (WRITE-TO-STRING (|lineNo| |pos|)) ", column "
+ (WRITE-TO-STRING (|lineCharacter| |pos|)))))))
(DEFUN |SoftShoeError| (|posn| |key|)
(PROGN
- (|coreError| (LIST "in line " (WRITE-TO-STRING (|lineNo| |posn|))))
- (|shoeConsole| (|lineString| |posn|))
- (|shoeConsole|
- (CONCAT (|shoeSpaces| (|lineCharacter| |posn|)) "|"))
- (|shoeConsole| |key|)))
+ (|coreError| (LIST "in line " (WRITE-TO-STRING (|lineNo| |posn|))))
+ (|shoeConsole| (|lineString| |posn|))
+ (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |posn|)) "|"))
+ (|shoeConsole| |key|)))
(DEFUN |bpSpecificErrorAtToken| (|tok| |key|)
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (|shoeTokPosn| |tok|))
- (|SoftShoeError| |a| |key|)))))
+ (PROGN (SETQ |a| (|shoeTokPosn| |tok|)) (|SoftShoeError| |a| |key|)))))
(DEFUN |bpSpecificErrorHere| (|key|)
(DECLARE (SPECIAL |$stok|))
@@ -59,18 +53,14 @@
(DEFUN |bpIgnoredFromTo| (|pos1| |pos2|)
(PROGN
- (|shoeConsole|
- (CONCAT "ignored from line "
- (WRITE-TO-STRING (|lineNo| |pos1|))))
- (|shoeConsole| (|lineString| |pos1|))
- (|shoeConsole|
- (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|"))
- (|shoeConsole|
- (CONCAT "ignored through line "
- (WRITE-TO-STRING (|lineNo| |pos2|))))
- (|shoeConsole| (|lineString| |pos2|))
- (|shoeConsole|
- (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|"))))
+ (|shoeConsole|
+ (CONCAT "ignored from line " (WRITE-TO-STRING (|lineNo| |pos1|))))
+ (|shoeConsole| (|lineString| |pos1|))
+ (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |pos1|)) "|"))
+ (|shoeConsole|
+ (CONCAT "ignored through line " (WRITE-TO-STRING (|lineNo| |pos2|))))
+ (|shoeConsole| (|lineString| |pos2|))
+ (|shoeConsole| (CONCAT (|shoeSpaces| (|lineCharacter| |pos2|)) "|"))))
(DEFUN |lineNo| (|p|) (CDAAR |p|))
@@ -83,30 +73,29 @@
(DEFUN |bStreamNull| (|x|)
(PROG (|st| |args| |op| |ISTMP#1|)
(RETURN
- (COND
- ((OR (NULL |x|) (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|)))
- T)
- (T (LOOP
+ (COND ((OR (NULL |x|) (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|))) T)
+ (T
+ (LOOP
(COND
- ((NOT (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |op| (CAR |ISTMP#1|))
- (SETQ |args| (CDR |ISTMP#1|))
- T)))))
- (RETURN NIL))
- (T (SETQ |st| (APPLY |op| |args|))
- (RPLACA |x| (CAR |st|)) (RPLACD |x| (CDR |st|)))))
- (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|)))))))
+ ((NOT
+ (AND (CONSP |x|) (EQ (CAR |x|) '|nonnullstream|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |op| (CAR |ISTMP#1|))
+ (SETQ |args| (CDR |ISTMP#1|))
+ T)))))
+ (RETURN NIL))
+ (T (SETQ |st| (APPLY |op| |args|)) (RPLACA |x| (CAR |st|))
+ (RPLACD |x| (CDR |st|)))))
+ (AND (CONSP |x|) (EQ (CAR |x|) '|nullstream|)))))))
(DEFUN |bMap| (|f| |x|) (|bDelay| #'|bMap1| (LIST |f| |x|)))
(DEFUN |bMap1| (|f| |x|)
- (COND
- ((|bStreamNull| |x|) |$bStreamNil|)
- (T (CONS (APPLY |f| (LIST (CAR |x|))) (|bMap| |f| (CDR |x|))))))
+ (COND ((|bStreamNull| |x|) |$bStreamNil|)
+ (T (CONS (APPLY |f| (LIST (CAR |x|))) (|bMap| |f| (CDR |x|))))))
(DEFUN |bDelay| (|f| |x|) (CONS '|nonnullstream| (CONS |f| |x|)))
@@ -114,45 +103,42 @@
(DEFUN |bAppend1| (|x| |y|)
(COND
- ((|bStreamNull| |x|)
- (COND ((|bStreamNull| |y|) (LIST '|nullstream|)) (T |y|)))
- (T (CONS (CAR |x|) (|bAppend| (CDR |x|) |y|)))))
+ ((|bStreamNull| |x|)
+ (COND ((|bStreamNull| |y|) (LIST '|nullstream|)) (T |y|)))
+ (T (CONS (CAR |x|) (|bAppend| (CDR |x|) |y|)))))
(DEFUN |bNext| (|f| |s|) (|bDelay| #'|bNext1| (LIST |f| |s|)))
(DEFUN |bNext1| (|f| |s|)
(PROG (|h|)
(RETURN
- (COND
- ((|bStreamNull| |s|) (LIST '|nullstream|))
- (T (SETQ |h| (APPLY |f| (LIST |s|)))
- (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|))))))))
+ (COND ((|bStreamNull| |s|) (LIST '|nullstream|))
+ (T (SETQ |h| (APPLY |f| (LIST |s|)))
+ (|bAppend| (CAR |h|) (|bNext| |f| (CDR |h|))))))))
(DEFUN |bRgen| (|s|) (|bDelay| #'|bRgen1| (LIST |s|)))
(DEFUN |bRgen1| (|s|)
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (|readLine| |s|))
- (COND
- ((NOT (EQ |a| |%nothing|)) (CONS |a| (|bRgen| |s|)))
- (T (LIST '|nullstream|)))))))
+ (PROGN
+ (SETQ |a| (|readLine| |s|))
+ (COND ((NOT (EQ |a| |%nothing|)) (CONS |a| (|bRgen| |s|)))
+ (T (LIST '|nullstream|)))))))
(DEFUN |bIgen| (|n|) (|bDelay| #'|bIgen1| (LIST |n|)))
-(DEFUN |bIgen1| (|n|)
- (PROGN (SETQ |n| (+ |n| 1)) (CONS |n| (|bIgen| |n|))))
+(DEFUN |bIgen1| (|n|) (PROGN (SETQ |n| (+ |n| 1)) (CONS |n| (|bIgen| |n|))))
(DEFUN |bAddLineNumber| (|f1| |f2|)
(|bDelay| #'|bAddLineNumber1| (LIST |f1| |f2|)))
(DEFUN |bAddLineNumber1| (|f1| |f2|)
- (COND
- ((|bStreamNull| |f1|) (LIST '|nullstream|))
- ((|bStreamNull| |f2|) (LIST '|nullstream|))
- (T (CONS (CONS (CAR |f1|) (CAR |f2|))
- (|bAddLineNumber| (CDR |f1|) (CDR |f2|))))))
+ (COND ((|bStreamNull| |f1|) (LIST '|nullstream|))
+ ((|bStreamNull| |f2|) (LIST '|nullstream|))
+ (T
+ (CONS (CONS (CAR |f1|) (CAR |f2|))
+ (|bAddLineNumber| (CDR |f1|) (CDR |f2|))))))
(DEFUN |shoePrefixLisp| (|x|) (CONCAT ")lisp" |x|))
@@ -161,26 +147,22 @@
(DEFUN |shoePrefix?| (|prefix| |whole|)
(PROG (|good|)
(RETURN
- (COND
- ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL)
- (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|
- (CHAR= (SCHAR |prefix| |i|)
- (SCHAR |whole| |j|)))))
+ (COND ((< (LENGTH |whole|) (LENGTH |prefix|)) NIL)
+ (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|
+ (CHAR= (SCHAR |prefix| |i|)
+ (SCHAR |whole| |j|)))))
(SETQ |i| (+ |i| 1))
(SETQ |j| (+ |j| 1))))
- (COND
- (|good| (|subString| |whole| (LENGTH |prefix|)))
- (T |good|)))))))
+ (COND (|good| (|subString| |whole| (LENGTH |prefix|)))
+ (T |good|)))))))
(DEFUN |shoePlainLine?| (|s|)
- (COND
- ((EQL (LENGTH |s|) 0) T)
- (T (NOT (CHAR= (SCHAR |s| 0) (|char| '|)|))))))
+ (COND ((EQL (LENGTH |s|) 0) T) (T (NOT (CHAR= (SCHAR |s| 0) (|char| '|)|))))))
(DEFUN |shoeSay?| (|s|) (|shoePrefix?| ")say" |s|))
@@ -203,69 +185,61 @@
(DEFUN |shoeBiteOff| (|x|)
(PROG (|n1| |n|)
(RETURN
- (PROGN
- (SETQ |n| (STRPOSL " " |x| 0 T))
- (COND
- ((NULL |n|) NIL)
- (T (SETQ |n1| (STRPOSL " " |x| |n| NIL))
- (COND
- ((NULL |n1|) (LIST (|subString| |x| |n|) ""))
- (T (LIST (|subString| |x| |n| (- |n1| |n|))
- (|subString| |x| |n1|))))))))))
+ (PROGN
+ (SETQ |n| (STRPOSL " " |x| 0 T))
+ (COND ((NULL |n|) NIL)
+ (T (SETQ |n1| (STRPOSL " " |x| |n| NIL))
+ (COND ((NULL |n1|) (LIST (|subString| |x| |n|) ""))
+ (T
+ (LIST (|subString| |x| |n| (- |n1| |n|))
+ (|subString| |x| |n1|))))))))))
(DEFUN |shoeFileName| (|x|)
(PROG (|c| |a|)
(RETURN
- (PROGN
- (SETQ |a| (|shoeBiteOff| |x|))
- (COND
- ((NULL |a|) "")
- (T (SETQ |c| (|shoeBiteOff| (CADR |a|)))
- (COND
- ((NULL |c|) (CAR |a|))
- (T (CONCAT (CAR |a|) "." (CAR |c|))))))))))
+ (PROGN
+ (SETQ |a| (|shoeBiteOff| |x|))
+ (COND ((NULL |a|) "")
+ (T (SETQ |c| (|shoeBiteOff| (CADR |a|)))
+ (COND ((NULL |c|) (CAR |a|))
+ (T (CONCAT (CAR |a|) "." (CAR |c|))))))))))
(DEFUN |shoeFnFileName| (|x|)
(PROG (|c| |a|)
(RETURN
- (PROGN
- (SETQ |a| (|shoeBiteOff| |x|))
- (COND
- ((NULL |a|) (LIST "" ""))
- (T (SETQ |c| (|shoeFileName| (CADR |a|)))
- (COND
- ((NULL |c|) (LIST (CAR |a|) ""))
- (T (LIST (CAR |a|) |c|)))))))))
+ (PROGN
+ (SETQ |a| (|shoeBiteOff| |x|))
+ (COND ((NULL |a|) (LIST "" ""))
+ (T (SETQ |c| (|shoeFileName| (CADR |a|)))
+ (COND ((NULL |c|) (LIST (CAR |a|) ""))
+ (T (LIST (CAR |a|) |c|)))))))))
(DEFUN |shoeInclude| (|s|) (|bDelay| #'|shoeInclude1| (LIST |s|)))
(DEFUN |shoeInclude1| (|s|)
(PROG (|command| |string| |t| |h|)
(RETURN
- (COND
- ((|bStreamNull| |s|) |s|)
- (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|))
- (T (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|)))))))))
+ (COND ((|bStreamNull| |s|) |s|)
+ (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|))
+ (T
+ (|bAppend| (|shoeSimpleLine| |h|) (|shoeInclude| |t|)))))))))
(DEFUN |shoeSimpleLine| (|h|)
(PROG (|command| |string|)
(RETURN
- (PROGN
- (SETQ |string| (CAR |h|))
- (COND
- ((|shoePlainLine?| |string|) (LIST |h|))
- ((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|))
- ((SETQ |command| (|shoeLine?| |string|)) (LIST |h|))
- ((SETQ |command| (|shoeSay?| |string|))
- (|shoeConsole| |command|) NIL)
- ((SETQ |command| (|shoeEval?| |string|)) (STTOMC |command|)
- NIL)
- (T (|shoeLineSyntaxError| |h|) NIL))))))
+ (PROGN
+ (SETQ |string| (CAR |h|))
+ (COND ((|shoePlainLine?| |string|) (LIST |h|))
+ ((SETQ |command| (|shoeLisp?| |string|)) (LIST |h|))
+ ((SETQ |command| (|shoeLine?| |string|)) (LIST |h|))
+ ((SETQ |command| (|shoeSay?| |string|)) (|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|)))
@@ -273,44 +247,40 @@
(DEFUN |shoeThen1| (|keep| |b| |s|)
(PROG (|b1| |keep1| |command| |string| |t| |h|)
(RETURN
- (COND
- ((|bPremStreamNull| |s|) |s|)
- (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND
- ((SETQ |command| (|shoeFin?| |string|))
- (|bPremStreamNil| |h|))
+ (COND ((|bPremStreamNull| |s|) |s|)
+ (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
+ (SETQ |string| (CAR |h|))
+ (COND
+ ((SETQ |command| (|shoeFin?| |string|)) (|bPremStreamNil| |h|))
(T (SETQ |keep1| (CAR |keep|)) (SETQ |b1| (CAR |b|))
+ (COND
+ ((SETQ |command| (|shoeIf?| |string|))
(COND
- ((SETQ |command| (|shoeIf?| |string|))
- (COND
- ((AND |keep1| |b1|)
- (|shoeThen| (CONS T |keep|)
- (CONS (STTOMC |command|) |b|) |t|))
- (T (|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|))
- (T (|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|))
- (T (|shoeElse| (CONS NIL (CDR |keep|))
- (CONS NIL (CDR |b|)) |t|))))
- ((SETQ |command| (|shoeEndIf?| |string|))
- (COND
- ((NULL (CDR |b|)) (|shoeInclude| |t|))
- (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
- ((AND |keep1| |b1|)
- (|bAppend| (|shoeSimpleLine| |h|)
- (|shoeThen| |keep| |b| |t|)))
- (T (|shoeThen| |keep| |b| |t|))))))))))
+ ((AND |keep1| |b1|)
+ (|shoeThen| (CONS T |keep|) (CONS (STTOMC |command|) |b|)
+ |t|))
+ (T (|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|))
+ (T
+ (|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|))
+ (T
+ (|shoeElse| (CONS NIL (CDR |keep|)) (CONS NIL (CDR |b|))
+ |t|))))
+ ((SETQ |command| (|shoeEndIf?| |string|))
+ (COND ((NULL (CDR |b|)) (|shoeInclude| |t|))
+ (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
+ ((AND |keep1| |b1|)
+ (|bAppend| (|shoeSimpleLine| |h|) (|shoeThen| |keep| |b| |t|)))
+ (T (|shoeThen| |keep| |b| |t|))))))))))
(DEFUN |shoeElse| (|keep| |b| |s|)
(|bDelay| #'|shoeElse1| (LIST |keep| |b| |s|)))
@@ -318,50 +288,42 @@
(DEFUN |shoeElse1| (|keep| |b| |s|)
(PROG (|keep1| |b1| |command| |string| |t| |h|)
(RETURN
- (COND
- ((|bPremStreamNull| |s|) |s|)
- (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
- (SETQ |string| (CAR |h|))
- (COND
- ((SETQ |command| (|shoeFin?| |string|))
- (|bPremStreamNil| |h|))
+ (COND ((|bPremStreamNull| |s|) |s|)
+ (T (SETQ |h| (CAR |s|)) (SETQ |t| (CDR |s|))
+ (SETQ |string| (CAR |h|))
+ (COND
+ ((SETQ |command| (|shoeFin?| |string|)) (|bPremStreamNil| |h|))
(T (SETQ |b1| (CAR |b|)) (SETQ |keep1| (CAR |keep|))
+ (COND
+ ((SETQ |command| (|shoeIf?| |string|))
(COND
- ((SETQ |command| (|shoeIf?| |string|))
- (COND
- ((AND |keep1| |b1|)
- (|shoeThen| (CONS T |keep|)
- (CONS (STTOMC |command|) |b|) |t|))
- (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|)
- |t|))))
- ((SETQ |command| (|shoeEndIf?| |string|))
- (COND
- ((NULL (CDR |b|)) (|shoeInclude| |t|))
- (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
- ((AND |keep1| |b1|)
- (|bAppend| (|shoeSimpleLine| |h|)
- (|shoeElse| |keep| |b| |t|)))
- (T (|shoeElse| |keep| |b| |t|))))))))))
+ ((AND |keep1| |b1|)
+ (|shoeThen| (CONS T |keep|) (CONS (STTOMC |command|) |b|)
+ |t|))
+ (T (|shoeThen| (CONS NIL |keep|) (CONS NIL |b|) |t|))))
+ ((SETQ |command| (|shoeEndIf?| |string|))
+ (COND ((NULL (CDR |b|)) (|shoeInclude| |t|))
+ (T (|shoeThen| (CDR |keep|) (CDR |b|) |t|))))
+ ((AND |keep1| |b1|)
+ (|bAppend| (|shoeSimpleLine| |h|) (|shoeElse| |keep| |b| |t|)))
+ (T (|shoeElse| |keep| |b| |t|))))))))))
(DEFUN |shoeLineSyntaxError| (|h|)
(PROGN
- (|shoeConsole|
- (CONCAT "INCLUSION SYNTAX ERROR IN LINE "
- (WRITE-TO-STRING (CDR |h|))))
- (|shoeConsole| (CAR |h|))
- (|shoeConsole| "LINE IGNORED")))
+ (|shoeConsole|
+ (CONCAT "INCLUSION SYNTAX ERROR IN LINE " (WRITE-TO-STRING (CDR |h|))))
+ (|shoeConsole| (CAR |h|))
+ (|shoeConsole| "LINE IGNORED")))
(DEFUN |bPremStreamNil| (|h|)
(PROGN
- (|shoeConsole|
- (CONCAT "UNEXPECTED )fin IN LINE " (WRITE-TO-STRING (CDR |h|))))
- (|shoeConsole| (CAR |h|))
- (|shoeConsole| "REST OF FILE IGNORED")
- |$bStreamNil|))
+ (|shoeConsole|
+ (CONCAT "UNEXPECTED )fin IN LINE " (WRITE-TO-STRING (CDR |h|))))
+ (|shoeConsole| (CAR |h|))
+ (|shoeConsole| "REST OF FILE IGNORED")
+ |$bStreamNil|))
(DEFUN |bPremStreamNull| (|s|)
- (COND
- ((|bStreamNull| |s|)
- (|shoeConsole| "FILE TERMINATED BEFORE )endif") T)
- (T NIL)))
+ (COND ((|bStreamNull| |s|) (|shoeConsole| "FILE TERMINATED BEFORE )endif") T)
+ (T NIL)))
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index 0d5f4199..898c6192 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -10,39 +10,32 @@
(PROVIDE "parser")
(DEFUN |bpFirstToken| ()
- (DECLARE (SPECIAL |$ttok| |$stok| |$inputStream|))
+ (DECLARE (SPECIAL |$inputStream| |$stok| |$ttok|))
(PROGN
- (SETQ |$stok|
- (COND
+ (SETQ |$stok|
+ (COND
((NULL |$inputStream|)
- (|shoeTokConstruct| 'ERROR 'NOMORE
- (|shoeTokPosn| |$stok|)))
+ (|shoeTokConstruct| 'ERROR 'NOMORE (|shoeTokPosn| |$stok|)))
(T (CAR |$inputStream|))))
- (SETQ |$ttok| (|shoeTokPart| |$stok|))
- T))
+ (SETQ |$ttok| (|shoeTokPart| |$stok|))
+ T))
(DEFUN |bpFirstTok| ()
- (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$ttok| |$stok|
- |$inputStream|))
+ (DECLARE (SPECIAL |$inputStream| |$stok| |$ttok| |$bpParenCount| |$bpCount|))
(PROGN
- (SETQ |$stok|
- (COND
+ (SETQ |$stok|
+ (COND
((NULL |$inputStream|)
- (|shoeTokConstruct| 'ERROR 'NOMORE
- (|shoeTokPosn| |$stok|)))
+ (|shoeTokConstruct| 'ERROR 'NOMORE (|shoeTokPosn| |$stok|)))
(T (CAR |$inputStream|))))
- (SETQ |$ttok| (|shoeTokPart| |$stok|))
- (COND
- ((AND (PLUSP |$bpParenCount|) (CONSP |$stok|)
- (EQ (CAR |$stok|) 'KEY))
- (COND
- ((EQ |$ttok| 'SETTAB) (SETQ |$bpCount| (+ |$bpCount| 1))
- (|bpNext|))
- ((EQ |$ttok| 'BACKTAB) (SETQ |$bpCount| (- |$bpCount| 1))
- (|bpNext|))
- ((EQ |$ttok| 'BACKSET) (|bpNext|))
- (T T)))
- (T T))))
+ (SETQ |$ttok| (|shoeTokPart| |$stok|))
+ (COND
+ ((AND (PLUSP |$bpParenCount|) (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY))
+ (COND ((EQ |$ttok| 'SETTAB) (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|))
+ ((EQ |$ttok| 'BACKTAB) (SETQ |$bpCount| (- |$bpCount| 1))
+ (|bpNext|))
+ ((EQ |$ttok| 'BACKSET) (|bpNext|)) (T T)))
+ (T T))))
(DEFUN |bpNext| ()
(DECLARE (SPECIAL |$inputStream|))
@@ -53,201 +46,179 @@
(PROGN (SETQ |$inputStream| (CDR |$inputStream|)) (|bpFirstToken|)))
(DEFUN |bpState| ()
- (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| |$inputStream|))
+ (DECLARE (SPECIAL |$inputStream| |$stack| |$bpParenCount| |$bpCount|))
(LIST |$inputStream| |$stack| |$bpParenCount| |$bpCount|))
(DEFUN |bpRestore| (|x|)
- (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| |$inputStream|))
+ (DECLARE (SPECIAL |$inputStream| |$stack| |$bpParenCount| |$bpCount|))
(PROGN
- (SETQ |$inputStream| (CAR |x|))
- (|bpFirstToken|)
- (SETQ |$stack| (CADR |x|))
- (SETQ |$bpParenCount| (CADDR |x|))
- (SETQ |$bpCount| (CADDDR |x|))
- T))
+ (SETQ |$inputStream| (CAR |x|))
+ (|bpFirstToken|)
+ (SETQ |$stack| (CADR |x|))
+ (SETQ |$bpParenCount| (CADDR |x|))
+ (SETQ |$bpCount| (CADDDR |x|))
+ T))
(DEFUN |bpPush| (|x|)
(DECLARE (SPECIAL |$stack|))
(SETQ |$stack| (CONS |x| |$stack|)))
(DEFUN |bpPushId| ()
- (DECLARE (SPECIAL |$stack| |$ttok|))
+ (DECLARE (SPECIAL |$ttok| |$stack|))
(SETQ |$stack| (CONS (|bfReName| |$ttok|) |$stack|)))
(DEFUN |bpPop1| ()
(PROG (|a|)
(DECLARE (SPECIAL |$stack|))
(RETURN
- (PROGN
- (SETQ |a| (CAR |$stack|))
- (SETQ |$stack| (CDR |$stack|))
- |a|))))
+ (PROGN (SETQ |a| (CAR |$stack|)) (SETQ |$stack| (CDR |$stack|)) |a|))))
(DEFUN |bpPop2| ()
(PROG (|a|)
(DECLARE (SPECIAL |$stack|))
(RETURN
- (PROGN
- (SETQ |a| (CADR |$stack|))
- (RPLACD |$stack| (CDDR |$stack|))
- |a|))))
+ (PROGN (SETQ |a| (CADR |$stack|)) (RPLACD |$stack| (CDDR |$stack|)) |a|))))
(DEFUN |bpPop3| ()
(PROG (|a|)
(DECLARE (SPECIAL |$stack|))
(RETURN
- (PROGN
- (SETQ |a| (CADDR |$stack|))
- (RPLACD (CDR |$stack|) (CDDDR |$stack|))
- |a|))))
+ (PROGN
+ (SETQ |a| (CADDR |$stack|))
+ (RPLACD (CDR |$stack|) (CDDDR |$stack|))
+ |a|))))
(DEFUN |bpIndentParenthesized| (|f|)
(PROG (|$bpCount| |a|)
- (DECLARE (SPECIAL |$inputStream| |$bpCount| |$bpParenCount|
- |$stok|))
+ (DECLARE (SPECIAL |$stok| |$bpParenCount| |$inputStream| |$bpCount|))
(RETURN
- (PROGN
- (SETQ |$bpCount| 0)
- (SETQ |a| |$stok|)
+ (PROGN
+ (SETQ |$bpCount| 0)
+ (SETQ |a| |$stok|)
+ (COND
+ ((|bpEqPeek| 'OPAREN) (SETQ |$bpParenCount| (+ |$bpParenCount| 1))
+ (|bpNext|)
(COND
- ((|bpEqPeek| 'OPAREN)
- (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) (|bpNext|)
- (COND
- ((AND (APPLY |f| NIL) (|bpFirstTok|)
- (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|)))
- (SETQ |$bpParenCount| (- |$bpParenCount| 1))
- (|bpNextToken|)
- (COND
- ((EQL |$bpCount| 0) T)
- (T (SETQ |$inputStream|
- (|append| (|bpAddTokens| |$bpCount|)
- |$inputStream|))
- (|bpFirstToken|)
- (COND
- ((EQL |$bpParenCount| 0) (|bpCancel|) T)
- (T T)))))
- ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL))
- (SETQ |$bpParenCount| (- |$bpParenCount| 1))
- (|bpNextToken|) T)
- (T (|bpParenTrap| |a|))))
- (T NIL))))))
+ ((AND (APPLY |f| NIL) (|bpFirstTok|)
+ (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|)))
+ (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|)
+ (COND ((EQL |$bpCount| 0) T)
+ (T
+ (SETQ |$inputStream|
+ (|append| (|bpAddTokens| |$bpCount|) |$inputStream|))
+ (|bpFirstToken|)
+ (COND ((EQL |$bpParenCount| 0) (|bpCancel|) T) (T T)))))
+ ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL))
+ (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|) T)
+ (T (|bpParenTrap| |a|))))
+ (T NIL))))))
(DEFUN |bpParenthesized| (|f|)
(PROG (|a|)
(DECLARE (SPECIAL |$stok|))
(RETURN
- (PROGN
- (SETQ |a| |$stok|)
+ (PROGN
+ (SETQ |a| |$stok|)
+ (COND
+ ((|bpEqKey| 'OPAREN)
(COND
- ((|bpEqKey| 'OPAREN)
- (COND
- ((AND (APPLY |f| NIL)
- (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|)))
- T)
- ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T)
- (T (|bpParenTrap| |a|))))
- (T NIL))))))
+ ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) T)
+ ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T)
+ (T (|bpParenTrap| |a|))))
+ (T NIL))))))
(DEFUN |bpBracket| (|f|)
(PROG (|a|)
(DECLARE (SPECIAL |$stok|))
(RETURN
- (PROGN
- (SETQ |a| |$stok|)
+ (PROGN
+ (SETQ |a| |$stok|)
+ (COND
+ ((|bpEqKey| 'OBRACK)
(COND
- ((|bpEqKey| 'OBRACK)
- (COND
- ((AND (APPLY |f| NIL)
- (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|)))
- (|bpPush| (|bfBracket| (|bpPop1|))))
- ((|bpEqKey| 'CBRACK) (|bpPush| NIL))
- (T (|bpBrackTrap| |a|))))
- (T NIL))))))
+ ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|)))
+ (|bpPush| (|bfBracket| (|bpPop1|))))
+ ((|bpEqKey| 'CBRACK) (|bpPush| NIL)) (T (|bpBrackTrap| |a|))))
+ (T NIL))))))
(DEFUN |bpPileBracketed| (|f|)
(COND
- ((|bpEqKey| 'SETTAB)
- (COND
- ((|bpEqKey| 'BACKTAB) T)
- ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'BACKTAB) (|bpPileTrap|)))
- (|bpPush| (|bfPile| (|bpPop1|))))
- (T NIL)))
- (T NIL)))
+ ((|bpEqKey| 'SETTAB)
+ (COND ((|bpEqKey| 'BACKTAB) T)
+ ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'BACKTAB) (|bpPileTrap|)))
+ (|bpPush| (|bfPile| (|bpPop1|))))
+ (T NIL)))
+ (T NIL)))
(DEFUN |bpListof| (|f| |str1| |g|)
(PROG (|a|)
(DECLARE (SPECIAL |$stack|))
(RETURN
- (COND
- ((APPLY |f| NIL)
- (COND
- ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|)))
- (SETQ |a| |$stack|) (SETQ |$stack| NIL)
- (LOOP
- (COND
- ((NOT (AND (|bpEqKey| |str1|)
- (OR (APPLY |f| NIL) (|bpTrap|))))
- (RETURN NIL))
- (T 0)))
- (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
- (|bpPush|
- (FUNCALL |g|
- (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))))
- (T T)))
- (T NIL)))))
+ (COND
+ ((APPLY |f| NIL)
+ (COND
+ ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|)))
+ (SETQ |a| |$stack|) (SETQ |$stack| NIL)
+ (LOOP
+ (COND
+ ((NOT (AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|))))
+ (RETURN NIL))
+ (T 0)))
+ (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
+ (|bpPush|
+ (FUNCALL |g| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))))
+ (T T)))
+ (T NIL)))))
(DEFUN |bpListofFun| (|f| |h| |g|)
(PROG (|a|)
(DECLARE (SPECIAL |$stack|))
(RETURN
- (COND
- ((APPLY |f| NIL)
- (COND
- ((AND (APPLY |h| NIL) (OR (APPLY |f| NIL) (|bpTrap|)))
- (SETQ |a| |$stack|) (SETQ |$stack| NIL)
- (LOOP
- (COND
- ((NOT (AND (APPLY |h| NIL)
- (OR (APPLY |f| NIL) (|bpTrap|))))
- (RETURN NIL))
- (T 0)))
- (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
- (|bpPush|
- (FUNCALL |g|
- (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))))
- (T T)))
- (T NIL)))))
+ (COND
+ ((APPLY |f| NIL)
+ (COND
+ ((AND (APPLY |h| NIL) (OR (APPLY |f| NIL) (|bpTrap|)))
+ (SETQ |a| |$stack|) (SETQ |$stack| NIL)
+ (LOOP
+ (COND
+ ((NOT (AND (APPLY |h| NIL) (OR (APPLY |f| NIL) (|bpTrap|))))
+ (RETURN NIL))
+ (T 0)))
+ (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
+ (|bpPush|
+ (FUNCALL |g| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))))
+ (T T)))
+ (T NIL)))))
(DEFUN |bpList| (|f| |str1|)
(PROG (|a|)
(DECLARE (SPECIAL |$stack|))
(RETURN
- (COND
- ((APPLY |f| NIL)
- (COND
- ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|)))
- (SETQ |a| |$stack|) (SETQ |$stack| NIL)
- (LOOP
- (COND
- ((NOT (AND (|bpEqKey| |str1|)
- (OR (APPLY |f| NIL) (|bpTrap|))))
- (RETURN NIL))
- (T 0)))
- (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
- (|bpPush| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))
- (T (|bpPush| (LIST (|bpPop1|))))))
- (T (|bpPush| NIL))))))
+ (COND
+ ((APPLY |f| NIL)
+ (COND
+ ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|)))
+ (SETQ |a| |$stack|) (SETQ |$stack| NIL)
+ (LOOP
+ (COND
+ ((NOT (AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|))))
+ (RETURN NIL))
+ (T 0)))
+ (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
+ (|bpPush| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))
+ (T (|bpPush| (LIST (|bpPop1|))))))
+ (T (|bpPush| NIL))))))
(DEFUN |bpOneOrMore| (|f|)
(PROG (|a|)
(DECLARE (SPECIAL |$stack|))
(RETURN
- (COND
- ((APPLY |f| NIL) (SETQ |a| |$stack|) (SETQ |$stack| NIL)
- (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) (T 0)))
- (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
- (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))
- (T NIL)))))
+ (COND
+ ((APPLY |f| NIL) (SETQ |a| |$stack|) (SETQ |$stack| NIL)
+ (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) (T 0)))
+ (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|))
+ (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))
+ (T NIL)))))
(DEFUN |bpAnyNo| (|s|)
(PROGN (LOOP (COND ((NOT (APPLY |s| NIL)) (RETURN NIL)) (T 0))) T))
@@ -258,48 +229,44 @@
(DEFUN |bpConditional| (|f|)
(COND
- ((AND (|bpEqKey| 'IF) (OR (|bpWhere|) (|bpTrap|))
- (OR (|bpEqKey| 'BACKSET) T))
- (COND
- ((|bpEqKey| 'SETTAB)
- (COND
- ((|bpEqKey| 'THEN)
- (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|)
- (|bpEqKey| 'BACKTAB)))
- (T (|bpMissing| 'THEN))))
+ ((AND (|bpEqKey| 'IF) (OR (|bpWhere|) (|bpTrap|))
+ (OR (|bpEqKey| 'BACKSET) T))
+ (COND
+ ((|bpEqKey| 'SETTAB)
+ (COND
((|bpEqKey| 'THEN)
- (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|)))
- (T (|bpMissing| '|then|))))
- (T NIL)))
+ (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|)
+ (|bpEqKey| 'BACKTAB)))
+ (T (|bpMissing| 'THEN))))
+ ((|bpEqKey| 'THEN) (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|)))
+ (T (|bpMissing| '|then|))))
+ (T NIL)))
(DEFUN |bpElse| (|f|)
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (|bpState|))
- (COND
- ((|bpBacksetElse|)
- (AND (OR (APPLY |f| NIL) (|bpTrap|))
- (|bpPush| (|bfIf| (|bpPop3|) (|bpPop2|) (|bpPop1|)))))
- (T (|bpRestore| |a|)
- (|bpPush| (|bfIfThenOnly| (|bpPop2|) (|bpPop1|)))))))))
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND
+ ((|bpBacksetElse|)
+ (AND (OR (APPLY |f| NIL) (|bpTrap|))
+ (|bpPush| (|bfIf| (|bpPop3|) (|bpPop2|) (|bpPop1|)))))
+ (T (|bpRestore| |a|)
+ (|bpPush| (|bfIfThenOnly| (|bpPop2|) (|bpPop1|)))))))))
(DEFUN |bpBacksetElse| ()
- (COND
- ((|bpEqKey| 'BACKSET) (|bpEqKey| 'ELSE))
- (T (|bpEqKey| 'ELSE))))
+ (COND ((|bpEqKey| 'BACKSET) (|bpEqKey| 'ELSE)) (T (|bpEqKey| 'ELSE))))
(DEFUN |bpEqPeek| (|s|)
- (DECLARE (SPECIAL |$ttok| |$stok|))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
(AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|)))
(DEFUN |bpEqKey| (|s|)
- (DECLARE (SPECIAL |$ttok| |$stok|))
- (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|)
- (|bpNext|)))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
+ (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|) (|bpNext|)))
(DEFUN |bpEqKeyNextTok| (|s|)
- (DECLARE (SPECIAL |$ttok| |$stok|))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
(AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (EQ |s| |$ttok|)
(|bpNextToken|)))
@@ -311,200 +278,186 @@
(DEFUN |bpMissingMate| (|close| |open|)
(PROGN
- (|bpSpecificErrorAtToken| |open| "possibly missing mate")
- (|bpMissing| |close|)))
+ (|bpSpecificErrorAtToken| |open| "possibly missing mate")
+ (|bpMissing| |close|)))
(DEFUN |bpMissing| (|s|)
(PROGN
- (|bpSpecificErrorHere| (CONCAT (PNAME |s|) " possibly missing"))
- (THROW :OPEN-AXIOM-CATCH-POINT
- (CONS :OPEN-AXIOM-CATCH-POINT
- (CONS '(|BootParserException|) 'TRAPPED)))))
+ (|bpSpecificErrorHere| (CONCAT (PNAME |s|) " possibly missing"))
+ (THROW :OPEN-AXIOM-CATCH-POINT
+ (CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootParserException|) 'TRAPPED)))))
(DEFUN |bpCompMissing| (|s|) (OR (|bpEqKey| |s|) (|bpMissing| |s|)))
(DEFUN |bpTrap| ()
(PROGN
- (|bpGeneralErrorHere|)
- (THROW :OPEN-AXIOM-CATCH-POINT
- (CONS :OPEN-AXIOM-CATCH-POINT
- (CONS '(|BootParserException|) 'TRAPPED)))))
+ (|bpGeneralErrorHere|)
+ (THROW :OPEN-AXIOM-CATCH-POINT
+ (CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootParserException|) 'TRAPPED)))))
(DEFUN |bpRecoverTrap| ()
(PROG (|pos2| |pos1|)
(DECLARE (SPECIAL |$stok|))
(RETURN
- (PROGN
- (|bpFirstToken|)
- (SETQ |pos1| (|shoeTokPosn| |$stok|))
- (|bpMoveTo| 0)
- (SETQ |pos2| (|shoeTokPosn| |$stok|))
- (|bpIgnoredFromTo| |pos1| |pos2|)
- (|bpPush| (LIST (LIST "pile syntax error")))))))
+ (PROGN
+ (|bpFirstToken|)
+ (SETQ |pos1| (|shoeTokPosn| |$stok|))
+ (|bpMoveTo| 0)
+ (SETQ |pos2| (|shoeTokPosn| |$stok|))
+ (|bpIgnoredFromTo| |pos1| |pos2|)
+ (|bpPush| (LIST (LIST "pile syntax error")))))))
(DEFUN |bpListAndRecover| (|f|)
(PROG (|found| |c| |done| |b| |a|)
- (DECLARE (SPECIAL |$inputStream| |$stack|))
+ (DECLARE (SPECIAL |$stack| |$inputStream|))
(RETURN
- (PROGN
- (SETQ |a| |$stack|)
- (SETQ |b| NIL)
- (SETQ |$stack| NIL)
- (SETQ |done| NIL)
- (SETQ |c| |$inputStream|)
- (LOOP
- (COND
- (|done| (RETURN NIL))
- (T (SETQ |found|
- (LET ((#0=#:G1354
- (CATCH :OPEN-AXIOM-CATCH-POINT
- (APPLY |f| NIL))))
- (COND
- ((AND (CONSP #0#)
- (EQUAL (CAR #0#)
- :OPEN-AXIOM-CATCH-POINT))
+ (PROGN
+ (SETQ |a| |$stack|)
+ (SETQ |b| NIL)
+ (SETQ |$stack| NIL)
+ (SETQ |done| NIL)
+ (SETQ |c| |$inputStream|)
+ (LOOP
+ (COND (|done| (RETURN NIL))
+ (T
+ (SETQ |found|
+ (LET ((#1=#:G719
+ (CATCH :OPEN-AXIOM-CATCH-POINT (APPLY |f| NIL))))
+ (COND
+ ((AND (CONSP #1#)
+ (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
(COND
- ((EQUAL (CAR #1=(CDR #0#))
- '(|BootParserException|))
- (LET ((|e| (CDR #1#))) |e|))
- (T (THROW :OPEN-AXIOM-CATCH-POINT #0#))))
- (T #0#))))
- (COND
- ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|)
- (|bpRecoverTrap|))
- ((NOT |found|) (SETQ |$inputStream| |c|)
- (|bpGeneralErrorHere|) (|bpRecoverTrap|)))
- (COND
- ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|))
- ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|))
- (SETQ |done| T))
- (T (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|)
- (|bpRecoverTrap|)
- (COND
+ ((EQUAL (CAR #2=(CDR #1#)) '(|BootParserException|))
+ (LET ((|e| (CDR #2#)))
+ |e|))
+ (T (THROW :OPEN-AXIOM-CATCH-POINT #1#))))
+ (T #1#))))
+ (COND
+ ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|)
+ (|bpRecoverTrap|))
+ ((NOT |found|) (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|)
+ (|bpRecoverTrap|)))
+ (COND ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|))
+ ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|))
+ (SETQ |done| T))
+ (T (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|)
+ (|bpRecoverTrap|)
+ (COND
((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|))
(SETQ |done| T))
(T (|bpNext|) (SETQ |c| |$inputStream|)))))
- (SETQ |b| (CONS (|bpPop1|) |b|)))))
- (SETQ |$stack| |a|)
- (|bpPush| (|reverse!| |b|))))))
+ (SETQ |b| (CONS (|bpPop1|) |b|)))))
+ (SETQ |$stack| |a|)
+ (|bpPush| (|reverse!| |b|))))))
(DEFUN |bpMoveTo| (|n|)
- (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$inputStream|))
- (COND
- ((NULL |$inputStream|) T)
- ((|bpEqPeek| 'BACKTAB)
- (COND
- ((EQL |n| 0) T)
- (T (|bpNextToken|) (SETQ |$bpCount| (- |$bpCount| 1))
- (|bpMoveTo| (- |n| 1)))))
- ((|bpEqPeek| 'BACKSET)
- (COND ((EQL |n| 0) T) (T (|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|))
- (T (|bpNextToken|) (|bpMoveTo| |n|))))
+ (DECLARE (SPECIAL |$inputStream| |$bpCount| |$bpParenCount|))
+ (COND ((NULL |$inputStream|) T)
+ ((|bpEqPeek| 'BACKTAB)
+ (COND ((EQL |n| 0) T)
+ (T (|bpNextToken|) (SETQ |$bpCount| (- |$bpCount| 1))
+ (|bpMoveTo| (- |n| 1)))))
+ ((|bpEqPeek| 'BACKSET)
+ (COND ((EQL |n| 0) T) (T (|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|))
+ (T (|bpNextToken|) (|bpMoveTo| |n|))))
(DEFUN |bpQualifiedName| ()
(DECLARE (SPECIAL |$stok|))
(COND
- ((|bpEqPeek| 'COLON-COLON) (|bpNext|)
- (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (|bpPushId|)
- (|bpNext|) (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|)))))
- (T NIL)))
+ ((|bpEqPeek| 'COLON-COLON) (|bpNext|)
+ (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (|bpPushId|) (|bpNext|)
+ (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|)))))
+ (T NIL)))
(DEFUN |bpName| ()
(DECLARE (SPECIAL |$stok|))
(COND
- ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID)) (|bpPushId|)
- (|bpNext|) (|bpAnyNo| #'|bpQualifiedName|))
- (T NIL)))
+ ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID)) (|bpPushId|) (|bpNext|)
+ (|bpAnyNo| #'|bpQualifiedName|))
+ (T NIL)))
(DEFUN |bpConstTok| ()
- (DECLARE (SPECIAL |$ttok| |$stok|))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
(COND
- ((|symbolMember?| (|shoeTokType| |$stok|) '(INTEGER FLOAT))
- (|bpPush| |$ttok|) (|bpNext|))
- ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISP))
- (AND (|bpPush| (|%Lisp| |$ttok|)) (|bpNext|)))
- ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISPEXP))
- (AND (|bpPush| |$ttok|) (|bpNext|)))
- ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LINE))
- (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|)))
- ((|bpEqPeek| 'QUOTE) (|bpNext|)
- (AND (OR (|bpSexp|) (|bpTrap|))
- (|bpPush| (|bfSymbol| (|bpPop1|)))))
- (T (|bpString|))))
+ ((|symbolMember?| (|shoeTokType| |$stok|) '(INTEGER FLOAT))
+ (|bpPush| |$ttok|) (|bpNext|))
+ ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISP))
+ (AND (|bpPush| (|%Lisp| |$ttok|)) (|bpNext|)))
+ ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LISPEXP))
+ (AND (|bpPush| |$ttok|) (|bpNext|)))
+ ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'LINE))
+ (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|)))
+ ((|bpEqPeek| 'QUOTE) (|bpNext|)
+ (AND (OR (|bpSexp|) (|bpTrap|)) (|bpPush| (|bfSymbol| (|bpPop1|)))))
+ (T (|bpString|))))
(DEFUN |bpExportItemTail| ()
- (OR (AND (|bpEqKey| 'BEC) (OR (|bpAssign|) (|bpTrap|))
- (|bpPush| (|%Assignment| (|bpPop2|) (|bpPop1|))))
- (|bpSimpleDefinitionTail|)))
+ (OR
+ (AND (|bpEqKey| 'BEC) (OR (|bpAssign|) (|bpTrap|))
+ (|bpPush| (|%Assignment| (|bpPop2|) (|bpPop1|))))
+ (|bpSimpleDefinitionTail|)))
(DEFUN |bpExportItem| ()
(PROG (|a|)
(RETURN
- (COND
- ((|bpEqPeek| 'STRUCTURE) (|bpStruct|))
- (T (SETQ |a| (|bpState|))
- (COND
+ (COND ((|bpEqPeek| 'STRUCTURE) (|bpStruct|))
+ (T (SETQ |a| (|bpState|))
+ (COND
((|bpName|)
(COND
- ((|bpEqPeek| 'COLON) (|bpRestore| |a|)
- (OR (|bpSignature|) (|bpTrap|))
- (OR (|bpExportItemTail|) T))
- (T (|bpRestore| |a|) (|bpTypeAliasDefition|))))
+ ((|bpEqPeek| 'COLON) (|bpRestore| |a|)
+ (OR (|bpSignature|) (|bpTrap|)) (OR (|bpExportItemTail|) T))
+ (T (|bpRestore| |a|) (|bpTypeAliasDefition|))))
(T NIL)))))))
(DEFUN |bpExportItemList| () (|bpListAndRecover| #'|bpExportItem|))
(DEFUN |bpModuleInterface| ()
(COND
- ((|bpEqKey| 'WHERE)
- (OR (|bpPileBracketed| #'|bpExportItemList|)
- (AND (|bpExportItem|) (|bpPush| (LIST (|bpPop1|))))
- (|bpTrap|)))
- (T (|bpPush| NIL))))
+ ((|bpEqKey| 'WHERE)
+ (OR (|bpPileBracketed| #'|bpExportItemList|)
+ (AND (|bpExportItem|) (|bpPush| (LIST (|bpPop1|)))) (|bpTrap|)))
+ (T (|bpPush| NIL))))
(DEFUN |bpModuleExports| ()
- (COND
- ((|bpParenthesized| #'|bpIdList|)
- (|bpPush| (|bfUntuple| (|bpPop1|))))
- (T (|bpPush| NIL))))
+ (COND ((|bpParenthesized| #'|bpIdList|) (|bpPush| (|bfUntuple| (|bpPop1|))))
+ (T (|bpPush| NIL))))
(DEFUN |bpModule| ()
(COND
- ((|bpEqKey| 'MODULE) (OR (|bpName|) (|bpTrap|)) (|bpModuleExports|)
- (|bpModuleInterface|)
- (|bpPush| (|%Module| (|bpPop3|) (|bpPop2|) (|bpPop1|))))
- (T NIL)))
+ ((|bpEqKey| 'MODULE) (OR (|bpName|) (|bpTrap|)) (|bpModuleExports|)
+ (|bpModuleInterface|)
+ (|bpPush| (|%Module| (|bpPop3|) (|bpPop2|) (|bpPop1|))))
+ (T NIL)))
(DEFUN |bpImport| ()
(PROG (|a|)
(RETURN
- (COND
- ((|bpEqKey| 'IMPORT)
- (COND
- ((|bpNamespace|) (|bpPush| (|%Import| (|bpPop1|))))
- (T (SETQ |a| (|bpState|)) (OR (|bpName|) (|bpTrap|))
+ (COND
+ ((|bpEqKey| 'IMPORT)
+ (COND ((|bpNamespace|) (|bpPush| (|%Import| (|bpPop1|))))
+ (T (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|)))))
- (T (|bpPush| (|%Import| (|bpPop1|))))))))
- (T NIL)))))
+ ((|bpEqPeek| 'COLON) (|bpRestore| |a|)
+ (AND (OR (|bpSignature|) (|bpTrap|))
+ (OR (|bpEqKey| 'FOR) (|bpTrap|))
+ (OR (|bpName|) (|bpTrap|))
+ (|bpPush| (|%ImportSignature| (|bpPop1|) (|bpPop1|)))))
+ (T (|bpPush| (|%Import| (|bpPop1|))))))))
+ (T NIL)))))
(DEFUN |bpNamespace| ()
(AND (|bpEqKey| 'NAMESPACE) (OR (|bpName|) (|bpDot|))
(|bpPush| (|bfNamespace| (|bpPop1|)))))
(DEFUN |bpTypeAliasDefition| ()
- (AND (OR (|bpTerm| #'|bpIdList|) (|bpTrap|)) (|bpEqKey| 'TDEF)
- (|bpLogical|) (|bpPush| (|%TypeAlias| (|bpPop2|) (|bpPop1|)))))
+ (AND (OR (|bpTerm| #'|bpIdList|) (|bpTrap|)) (|bpEqKey| 'TDEF) (|bpLogical|)
+ (|bpPush| (|%TypeAlias| (|bpPop2|) (|bpPop1|)))))
(DEFUN |bpSignature| ()
(AND (|bpName|) (|bpEqKey| 'COLON) (|bpTyping|)
@@ -512,11 +465,11 @@
(DEFUN |bpSimpleMapping| ()
(COND
- ((|bpApplication|)
- (AND (|bpEqKey| 'ARROW) (OR (|bpApplication|) (|bpTrap|))
- (|bpPush| (|%Mapping| (|bpPop1|) (LIST (|bpPop1|)))))
- T)
- (T NIL)))
+ ((|bpApplication|)
+ (AND (|bpEqKey| 'ARROW) (OR (|bpApplication|) (|bpTrap|))
+ (|bpPush| (|%Mapping| (|bpPop1|) (LIST (|bpPop1|)))))
+ T)
+ (T NIL)))
(DEFUN |bpArgtypeList| () (|bpTuple| #'|bpApplication|))
@@ -528,28 +481,25 @@
(DEFUN |bpCancel| ()
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (|bpState|))
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND
+ ((|bpEqKeyNextTok| 'SETTAB)
(COND
- ((|bpEqKeyNextTok| 'SETTAB)
- (COND
- ((|bpCancel|)
- (COND
- ((|bpEqKeyNextTok| 'BACKTAB) T)
- (T (|bpRestore| |a|) NIL)))
- ((|bpEqKeyNextTok| 'BACKTAB) T)
- (T (|bpRestore| |a|) NIL)))
- (T NIL))))))
+ ((|bpCancel|)
+ (COND ((|bpEqKeyNextTok| 'BACKTAB) T) (T (|bpRestore| |a|) NIL)))
+ ((|bpEqKeyNextTok| 'BACKTAB) T) (T (|bpRestore| |a|) NIL)))
+ (T NIL))))))
(DEFUN |bpAddTokens| (|n|)
(DECLARE (SPECIAL |$stok|))
- (COND
- ((EQL |n| 0) NIL)
- ((PLUSP |n|)
- (CONS (|shoeTokConstruct| 'KEY 'SETTAB (|shoeTokPosn| |$stok|))
- (|bpAddTokens| (- |n| 1))))
- (T (CONS (|shoeTokConstruct| 'KEY 'BACKTAB (|shoeTokPosn| |$stok|))
- (|bpAddTokens| (+ |n| 1))))))
+ (COND ((EQL |n| 0) NIL)
+ ((PLUSP |n|)
+ (CONS (|shoeTokConstruct| 'KEY 'SETTAB (|shoeTokPosn| |$stok|))
+ (|bpAddTokens| (- |n| 1))))
+ (T
+ (CONS (|shoeTokConstruct| 'KEY 'BACKTAB (|shoeTokPosn| |$stok|))
+ (|bpAddTokens| (+ |n| 1))))))
(DEFUN |bpExceptions| ()
(OR (|bpEqPeek| 'DOT) (|bpEqPeek| 'QUOTE) (|bpEqPeek| 'OPAREN)
@@ -558,27 +508,24 @@
(DEFUN |bpSexpKey| ()
(PROG (|a|)
- (DECLARE (SPECIAL |$ttok| |$stok|))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
(RETURN
- (COND
- ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY)
- (NOT (|bpExceptions|)))
- (SETQ |a| (GET |$ttok| 'SHOEINF))
- (COND
- ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|)))
- (T (AND (|bpPush| |a|) (|bpNext|)))))
- (T NIL)))))
+ (COND
+ ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (NOT (|bpExceptions|)))
+ (SETQ |a| (GET |$ttok| 'SHOEINF))
+ (COND ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|)))
+ (T (AND (|bpPush| |a|) (|bpNext|)))))
+ (T NIL)))))
(DEFUN |bpAnyId| ()
- (DECLARE (SPECIAL |$ttok| |$stok|))
- (OR (AND (|bpEqKey| 'MINUS)
- (OR (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'INTEGER))
- (|bpTrap|))
- (|bpPush| (- |$ttok|)) (|bpNext|))
- (|bpSexpKey|)
- (AND (|symbolMember?| (|shoeTokType| |$stok|)
- '(ID INTEGER STRING FLOAT))
- (|bpPush| |$ttok|) (|bpNext|))))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
+ (OR
+ (AND (|bpEqKey| 'MINUS)
+ (OR (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'INTEGER)) (|bpTrap|))
+ (|bpPush| (- |$ttok|)) (|bpNext|))
+ (|bpSexpKey|)
+ (AND (|symbolMember?| (|shoeTokType| |$stok|) '(ID INTEGER STRING FLOAT))
+ (|bpPush| |$ttok|) (|bpNext|))))
(DEFUN |bpSexp| ()
(OR (|bpAnyId|)
@@ -587,24 +534,23 @@
(|bpIndentParenthesized| #'|bpSexp1|)))
(DEFUN |bpSexp1| ()
- (OR (AND (|bpFirstTok|) (|bpSexp|)
- (OR (AND (|bpEqKey| 'DOT) (|bpSexp|)
- (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))
- (AND (|bpSexp1|)
- (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))))
- (|bpPush| NIL)))
+ (OR
+ (AND (|bpFirstTok|) (|bpSexp|)
+ (OR
+ (AND (|bpEqKey| 'DOT) (|bpSexp|)
+ (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))
+ (AND (|bpSexp1|) (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))))
+ (|bpPush| NIL)))
(DEFUN |bpPrimary1| ()
- (OR (|bpParenthesizedApplication|) (|bpDot|) (|bpConstTok|)
- (|bpConstruct|) (|bpCase|) (|bpStruct|) (|bpPDefinition|)
- (|bpBPileDefinition|)))
+ (OR (|bpParenthesizedApplication|) (|bpDot|) (|bpConstTok|) (|bpConstruct|)
+ (|bpCase|) (|bpStruct|) (|bpPDefinition|) (|bpBPileDefinition|)))
(DEFUN |bpParenthesizedApplication| ()
(AND (|bpName|) (|bpAnyNo| #'|bpArgumentList|)))
(DEFUN |bpArgumentList| ()
- (AND (|bpPDefinition|)
- (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))))
+ (AND (|bpPDefinition|) (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))))
(DEFUN |bpPrimary| ()
(AND (|bpFirstTok|) (OR (|bpPrimary1|) (|bpPrefixOperator|))))
@@ -612,95 +558,94 @@
(DEFUN |bpDot| () (AND (|bpEqKey| 'DOT) (|bpPush| (|bfDot|))))
(DEFUN |bpPrefixOperator| ()
- (DECLARE (SPECIAL |$ttok| |$stok|))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
(AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (GET |$ttok| 'SHOEPRE)
(|bpPushId|) (|bpNext|)))
(DEFUN |bpInfixOperator| ()
- (DECLARE (SPECIAL |$ttok| |$stok|))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
(AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (GET |$ttok| 'SHOEINF)
(|bpPushId|) (|bpNext|)))
(DEFUN |bpSelector| ()
(AND (|bpEqKey| 'DOT)
- (OR (AND (|bpPrimary|)
- (|bpPush| (|bfElt| (|bpPop2|) (|bpPop1|))))
+ (OR (AND (|bpPrimary|) (|bpPush| (|bfElt| (|bpPop2|) (|bpPop1|))))
(|bpPush| (|bfSuffixDot| (|bpPop1|))))))
(DEFUN |bpApplication| ()
- (OR (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|)
- (OR (AND (|bpApplication|)
- (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|))))
- T))
- (|bpNamespace|)))
+ (OR
+ (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|)
+ (OR
+ (AND (|bpApplication|)
+ (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|))))
+ T))
+ (|bpNamespace|)))
(DEFUN |bpTyping| ()
(COND
- ((|bpEqKey| 'FORALL) (OR (|bpVariable|) (|bpTrap|))
- (OR (AND (|bpDot|) (|bpPop1|)) (|bpTrap|))
- (OR (|bpTyping|) (|bpTrap|))
- (|bpPush| (|%Forall| (|bpPop2|) (|bpPop1|))))
- (T (OR (|bpMapping|) (|bpSimpleMapping|)))))
+ ((|bpEqKey| 'FORALL) (OR (|bpVariable|) (|bpTrap|))
+ (OR (AND (|bpDot|) (|bpPop1|)) (|bpTrap|)) (OR (|bpTyping|) (|bpTrap|))
+ (|bpPush| (|%Forall| (|bpPop2|) (|bpPop1|))))
+ (T (OR (|bpMapping|) (|bpSimpleMapping|)))))
(DEFUN |bpTagged| ()
(AND (|bpApplication|)
- (OR (AND (|bpEqKey| 'COLON) (OR (|bpTyping|) (|bpTrap|))
- (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|))))
- T)))
+ (OR
+ (AND (|bpEqKey| 'COLON) (OR (|bpTyping|) (|bpTrap|))
+ (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|))))
+ T)))
(DEFUN |bpExpt| () (|bpRightAssoc| '(POWER) #'|bpTagged|))
(DEFUN |bpInfKey| (|s|)
- (DECLARE (SPECIAL |$ttok| |$stok|))
- (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY)
- (|symbolMember?| |$ttok| |s|) (|bpPushId|) (|bpNext|)))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
+ (AND (CONSP |$stok|) (EQ (CAR |$stok|) 'KEY) (|symbolMember?| |$ttok| |s|)
+ (|bpPushId|) (|bpNext|)))
-(DEFUN |bpInfGeneric| (|s|)
- (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T)))
+(DEFUN |bpInfGeneric| (|s|) (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T)))
(DEFUN |bpRightAssoc| (|o| |p|)
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (|bpState|))
- (COND
- ((APPLY |p| NIL)
- (LOOP
- (COND
- ((NOT (AND (|bpInfGeneric| |o|)
- (OR (|bpRightAssoc| |o| |p|) (|bpTrap|))))
- (RETURN NIL))
- (T (|bpPush|
- (|bfInfApplication| (|bpPop2|) (|bpPop2|)
- (|bpPop1|))))))
- T)
- (T (|bpRestore| |a|) NIL))))))
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND
+ ((APPLY |p| NIL)
+ (LOOP
+ (COND
+ ((NOT
+ (AND (|bpInfGeneric| |o|)
+ (OR (|bpRightAssoc| |o| |p|) (|bpTrap|))))
+ (RETURN NIL))
+ (T
+ (|bpPush| (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|))))))
+ T)
+ (T (|bpRestore| |a|) NIL))))))
(DEFUN |bpLeftAssoc| (|operations| |parser|)
(COND
- ((APPLY |parser| NIL)
- (LOOP
- (COND
- ((NOT (AND (|bpInfGeneric| |operations|)
- (OR (APPLY |parser| NIL) (|bpTrap|))))
- (RETURN NIL))
- (T (|bpPush|
- (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|))))))
- T)
- (T NIL)))
+ ((APPLY |parser| NIL)
+ (LOOP
+ (COND
+ ((NOT
+ (AND (|bpInfGeneric| |operations|)
+ (OR (APPLY |parser| NIL) (|bpTrap|))))
+ (RETURN NIL))
+ (T (|bpPush| (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|))))))
+ T)
+ (T NIL)))
(DEFUN |bpString| ()
- (DECLARE (SPECIAL |$ttok| |$stok|))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
(AND (EQ (|shoeTokType| |$stok|) 'STRING)
(|bpPush| (|quote| (INTERN |$ttok|))) (|bpNext|)))
(DEFUN |bpThetaName| ()
- (DECLARE (SPECIAL |$ttok| |$stok|))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
(COND
- ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID)
- (GET |$ttok| 'SHOETHETA))
- (|bpPushId|) (|bpNext|))
- (T NIL)))
+ ((AND (CONSP |$stok|) (EQ (CAR |$stok|) 'ID) (GET |$ttok| 'SHOETHETA))
+ (|bpPushId|) (|bpNext|))
+ (T NIL)))
(DEFUN |bpReduceOperator| ()
(OR (|bpInfixOperator|) (|bpString|) (|bpThetaName|)))
@@ -708,82 +653,80 @@
(DEFUN |bpReduce| ()
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (|bpState|))
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND
+ ((AND (|bpReduceOperator|) (|bpEqKey| 'SLASH))
(COND
- ((AND (|bpReduceOperator|) (|bpEqKey| 'SLASH))
- (COND
- ((|bpEqPeek| 'OBRACK)
- (AND (OR (|bpDConstruct|) (|bpTrap|))
- (|bpPush| (|bfReduceCollect| (|bpPop2|) (|bpPop1|)))))
- (T (AND (OR (|bpApplication|) (|bpTrap|))
- (|bpPush| (|bfReduce| (|bpPop2|) (|bpPop1|)))))))
- (T (|bpRestore| |a|) NIL))))))
+ ((|bpEqPeek| 'OBRACK)
+ (AND (OR (|bpDConstruct|) (|bpTrap|))
+ (|bpPush| (|bfReduceCollect| (|bpPop2|) (|bpPop1|)))))
+ (T
+ (AND (OR (|bpApplication|) (|bpTrap|))
+ (|bpPush| (|bfReduce| (|bpPop2|) (|bpPop1|)))))))
+ (T (|bpRestore| |a|) NIL))))))
-(DEFUN |bpTimes| ()
- (OR (|bpReduce|) (|bpLeftAssoc| '(TIMES SLASH) #'|bpExpt|)))
+(DEFUN |bpTimes| () (OR (|bpReduce|) (|bpLeftAssoc| '(TIMES SLASH) #'|bpExpt|)))
(DEFUN |bpEuclid| () (|bpLeftAssoc| '(QUO REM) #'|bpTimes|))
(DEFUN |bpMinus| ()
- (OR (AND (|bpInfGeneric| '(MINUS)) (OR (|bpEuclid|) (|bpTrap|))
- (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|))))
- (|bpEuclid|)))
+ (OR
+ (AND (|bpInfGeneric| '(MINUS)) (OR (|bpEuclid|) (|bpTrap|))
+ (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|))))
+ (|bpEuclid|)))
(DEFUN |bpArith| () (|bpLeftAssoc| '(PLUS MINUS) #'|bpMinus|))
(DEFUN |bpIs| ()
(AND (|bpArith|)
(COND
- ((AND (|bpInfKey| '(IS ISNT)) (OR (|bpPattern|) (|bpTrap|)))
- (|bpPush|
- (|bfISApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|))))
- ((AND (|bpEqKey| 'HAS) (OR (|bpApplication|) (|bpTrap|)))
- (|bpPush| (|bfHas| (|bpPop2|) (|bpPop1|))))
- (T T))))
+ ((AND (|bpInfKey| '(IS ISNT)) (OR (|bpPattern|) (|bpTrap|)))
+ (|bpPush| (|bfISApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|))))
+ ((AND (|bpEqKey| 'HAS) (OR (|bpApplication|) (|bpTrap|)))
+ (|bpPush| (|bfHas| (|bpPop2|) (|bpPop1|))))
+ (T T))))
(DEFUN |bpBracketConstruct| (|f|)
(AND (|bpBracket| |f|) (|bpPush| (|bfConstruct| (|bpPop1|)))))
(DEFUN |bpCompare| ()
- (OR (AND (|bpIs|)
- (OR (AND (|bpInfKey| '(SHOEEQ SHOENE LT LE GT GE IN))
- (OR (|bpIs|) (|bpTrap|))
- (|bpPush|
- (|bfInfApplication| (|bpPop2|) (|bpPop2|)
- (|bpPop1|))))
- T))
- (|bpLeave|) (|bpThrow|)))
+ (OR
+ (AND (|bpIs|)
+ (OR
+ (AND (|bpInfKey| '(SHOEEQ SHOENE LT LE GT GE IN))
+ (OR (|bpIs|) (|bpTrap|))
+ (|bpPush| (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|))))
+ T))
+ (|bpLeave|) (|bpThrow|)))
(DEFUN |bpAnd| () (|bpLeftAssoc| '(AND) #'|bpCompare|))
(DEFUN |bpThrow| ()
(COND
- ((AND (|bpEqKey| 'THROW) (|bpApplication|))
- (COND
- ((|bpEqKey| 'COLON) (OR (|bpApplication|) (|bpTrap|))
- (|bpPush| (|%Pretend| (|bpPop2|) (|bpPop1|)))))
- (|bpPush| (|bfThrow| (|bpPop1|))))
- (T NIL)))
+ ((AND (|bpEqKey| 'THROW) (|bpApplication|))
+ (COND
+ ((|bpEqKey| 'COLON) (OR (|bpApplication|) (|bpTrap|))
+ (|bpPush| (|%Pretend| (|bpPop2|) (|bpPop1|)))))
+ (|bpPush| (|bfThrow| (|bpPop1|))))
+ (T NIL)))
(DEFUN |bpTry| ()
(PROG (|cs|)
(RETURN
- (COND
- ((|bpEqKey| 'TRY) (|bpAssign|) (SETQ |cs| NIL)
- (LOOP
- (COND
- ((NOT (|bpHandler| 'CATCH)) (RETURN NIL))
- (T (|bpCatchItem|) (SETQ |cs| (CONS (|bpPop1|) |cs|)))))
- (COND
- ((|bpHandler| 'FINALLY)
- (AND (|bpFinally|)
- (|bpPush|
- (|bfTry| (|bpPop2|)
- (|reverse!| (CONS (|bpPop1|) |cs|))))))
- ((NULL |cs|) (|bpTrap|))
- (T (|bpPush| (|bfTry| (|bpPop1|) (|reverse!| |cs|))))))
- (T NIL)))))
+ (COND
+ ((|bpEqKey| 'TRY) (|bpAssign|) (SETQ |cs| NIL)
+ (LOOP
+ (COND ((NOT (|bpHandler| 'CATCH)) (RETURN NIL))
+ (T (|bpCatchItem|) (SETQ |cs| (CONS (|bpPop1|) |cs|)))))
+ (COND
+ ((|bpHandler| 'FINALLY)
+ (AND (|bpFinally|)
+ (|bpPush|
+ (|bfTry| (|bpPop2|) (|reverse!| (CONS (|bpPop1|) |cs|))))))
+ ((NULL |cs|) (|bpTrap|))
+ (T (|bpPush| (|bfTry| (|bpPop1|) (|reverse!| |cs|))))))
+ (T NIL)))))
(DEFUN |bpCatchItem| ()
(AND (OR (|bpExceptionVariable|) (|bpTrap|))
@@ -794,11 +737,12 @@
(PROG (|t|)
(DECLARE (SPECIAL |$stok|))
(RETURN
- (PROGN
- (SETQ |t| |$stok|)
- (OR (AND (|bpEqKey| 'OPAREN) (OR (|bpSignature|) (|bpTrap|))
- (OR (|bpEqKey| 'CPAREN) (|bpMissing| |t|)))
- (|bpTrap|))))))
+ (PROGN
+ (SETQ |t| |$stok|)
+ (OR
+ (AND (|bpEqKey| 'OPAREN) (OR (|bpSignature|) (|bpTrap|))
+ (OR (|bpEqKey| 'CPAREN) (|bpMissing| |t|)))
+ (|bpTrap|))))))
(DEFUN |bpFinally| ()
(AND (OR (|bpAssign|) (|bpTrap|)) (|bpPush| (|%Finally| (|bpPop1|)))))
@@ -806,13 +750,13 @@
(DEFUN |bpHandler| (|key|)
(PROG (|s|)
(RETURN
- (PROGN
- (SETQ |s| (|bpState|))
- (COND
- ((AND (OR (|bpEqKey| 'BACKSET) (|bpEqKey| 'SEMICOLON))
- (|bpEqKey| |key|))
- T)
- (T (|bpRestore| |s|) NIL))))))
+ (PROGN
+ (SETQ |s| (|bpState|))
+ (COND
+ ((AND (OR (|bpEqKey| 'BACKSET) (|bpEqKey| 'SEMICOLON))
+ (|bpEqKey| |key|))
+ T)
+ (T (|bpRestore| |s|) NIL))))))
(DEFUN |bpLeave| ()
(AND (|bpEqKey| 'LEAVE) (OR (|bpLogical|) (|bpTrap|))
@@ -820,36 +764,36 @@
(DEFUN |bpDo| ()
(COND
- ((|bpEqKey| 'IN) (OR (|bpNamespace|) (|bpTrap|))
- (OR (|bpDo|) (|bpTrap|))
- (|bpPush| (|bfAtScope| (|bpPop2|) (|bpPop1|))))
- (T (AND (|bpEqKey| 'DO) (OR (|bpAssign|) (|bpTrap|))
- (|bpPush| (|bfDo| (|bpPop1|)))))))
+ ((|bpEqKey| 'IN) (OR (|bpNamespace|) (|bpTrap|)) (OR (|bpDo|) (|bpTrap|))
+ (|bpPush| (|bfAtScope| (|bpPop2|) (|bpPop1|))))
+ (T
+ (AND (|bpEqKey| 'DO) (OR (|bpAssign|) (|bpTrap|))
+ (|bpPush| (|bfDo| (|bpPop1|)))))))
(DEFUN |bpReturn| ()
- (OR (AND (|bpEqKey| 'RETURN) (OR (|bpAssign|) (|bpTrap|))
- (|bpPush| (|bfReturnNoName| (|bpPop1|))))
- (|bpLeave|) (|bpThrow|) (|bpAnd|) (|bpDo|)))
+ (OR
+ (AND (|bpEqKey| 'RETURN) (OR (|bpAssign|) (|bpTrap|))
+ (|bpPush| (|bfReturnNoName| (|bpPop1|))))
+ (|bpLeave|) (|bpThrow|) (|bpAnd|) (|bpDo|)))
(DEFUN |bpLogical| () (|bpLeftAssoc| '(OR) #'|bpReturn|))
(DEFUN |bpExpression| ()
- (OR (AND (|bpEqKey| 'COLON)
- (OR (AND (|bpLogical|)
- (|bpPush| (|bfApplication| 'COLON (|bpPop1|))))
- (|bpTrap|)))
- (|bpLogical|)))
+ (OR
+ (AND (|bpEqKey| 'COLON)
+ (OR (AND (|bpLogical|) (|bpPush| (|bfApplication| 'COLON (|bpPop1|))))
+ (|bpTrap|)))
+ (|bpLogical|)))
(DEFUN |bpStatement| ()
- (OR (|bpConditional| #'|bpWhere|) (|bpLoop|) (|bpExpression|)
- (|bpTry|)))
+ (OR (|bpConditional| #'|bpWhere|) (|bpLoop|) (|bpExpression|) (|bpTry|)))
(DEFUN |bpLoop| ()
- (OR (AND (|bpIterators|) (|bpCompMissing| 'REPEAT)
- (OR (|bpWhere|) (|bpTrap|))
- (|bpPush| (|bfLp| (|bpPop2|) (|bpPop1|))))
- (AND (|bpEqKey| 'REPEAT) (OR (|bpLogical|) (|bpTrap|))
- (|bpPush| (|bfLoop1| (|bpPop1|))))))
+ (OR
+ (AND (|bpIterators|) (|bpCompMissing| 'REPEAT) (OR (|bpWhere|) (|bpTrap|))
+ (|bpPush| (|bfLp| (|bpPop2|) (|bpPop1|))))
+ (AND (|bpEqKey| 'REPEAT) (OR (|bpLogical|) (|bpTrap|))
+ (|bpPush| (|bfLoop1| (|bpPop1|))))))
(DEFUN |bpSuchThat| () (|bpAndOr| 'BAR #'|bpWhere| #'|bfSuchthat|))
@@ -860,32 +804,28 @@
(DEFUN |bpFormal| () (OR (|bpVariable|) (|bpDot|)))
(DEFUN |bpForIn| ()
- (AND (|bpEqKey| 'FOR) (OR (|bpFormal|) (|bpTrap|))
- (|bpCompMissing| 'IN)
- (OR (AND (OR (|bpSeg|) (|bpTrap|)) (|bpEqKey| 'BY)
- (OR (|bpArith|) (|bpTrap|))
- (|bpPush|
- (|bfForInBy| (|bpPop3|) (|bpPop2|) (|bpPop1|))))
- (|bpPush| (|bfForin| (|bpPop2|) (|bpPop1|))))))
+ (AND (|bpEqKey| 'FOR) (OR (|bpFormal|) (|bpTrap|)) (|bpCompMissing| 'IN)
+ (OR
+ (AND (OR (|bpSeg|) (|bpTrap|)) (|bpEqKey| 'BY)
+ (OR (|bpArith|) (|bpTrap|))
+ (|bpPush| (|bfForInBy| (|bpPop3|) (|bpPop2|) (|bpPop1|))))
+ (|bpPush| (|bfForin| (|bpPop2|) (|bpPop1|))))))
(DEFUN |bpSeg| ()
(AND (|bpArith|)
- (OR (AND (|bpEqKey| 'SEG)
- (OR (AND (|bpArith|)
- (|bpPush|
- (|bfSegment2| (|bpPop2|) (|bpPop1|))))
- (|bpPush| (|bfSegment1| (|bpPop1|)))))
- T)))
+ (OR
+ (AND (|bpEqKey| 'SEG)
+ (OR
+ (AND (|bpArith|) (|bpPush| (|bfSegment2| (|bpPop2|) (|bpPop1|))))
+ (|bpPush| (|bfSegment1| (|bpPop1|)))))
+ T)))
-(DEFUN |bpIterator| ()
- (OR (|bpForIn|) (|bpSuchThat|) (|bpWhile|) (|bpUntil|)))
+(DEFUN |bpIterator| () (OR (|bpForIn|) (|bpSuchThat|) (|bpWhile|) (|bpUntil|)))
(DEFUN |bpIteratorList| ()
- (AND (|bpOneOrMore| #'|bpIterator|)
- (|bpPush| (|bfIterators| (|bpPop1|)))))
+ (AND (|bpOneOrMore| #'|bpIterator|) (|bpPush| (|bfIterators| (|bpPop1|)))))
-(DEFUN |bpCrossBackSet| ()
- (AND (|bpEqKey| 'CROSS) (OR (|bpEqKey| 'BACKSET) T)))
+(DEFUN |bpCrossBackSet| () (AND (|bpEqKey| 'CROSS) (OR (|bpEqKey| 'BACKSET) T)))
(DEFUN |bpIterators| ()
(|bpListofFun| #'|bpIteratorList| #'|bpCrossBackSet| #'|bfCross|))
@@ -893,21 +833,18 @@
(DEFUN |bpAssign| ()
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (|bpState|))
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND
+ ((|bpStatement|)
(COND
- ((|bpStatement|)
- (COND
- ((|bpEqPeek| 'BEC) (|bpRestore| |a|)
- (OR (|bpAssignment|) (|bpTrap|)))
- ((|bpEqPeek| 'GIVES) (|bpRestore| |a|)
- (OR (|bpLambda|) (|bpTrap|)))
- (T T)))
- (T (|bpRestore| |a|) NIL))))))
+ ((|bpEqPeek| 'BEC) (|bpRestore| |a|) (OR (|bpAssignment|) (|bpTrap|)))
+ ((|bpEqPeek| 'GIVES) (|bpRestore| |a|) (OR (|bpLambda|) (|bpTrap|)))
+ (T T)))
+ (T (|bpRestore| |a|) NIL))))))
(DEFUN |bpAssignment| ()
- (AND (|bpAssignVariable|) (|bpEqKey| 'BEC)
- (OR (|bpAssign|) (|bpTrap|))
+ (AND (|bpAssignVariable|) (|bpEqKey| 'BEC) (OR (|bpAssign|) (|bpTrap|))
(|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))))
(DEFUN |bpLambda| ()
@@ -916,35 +853,35 @@
(DEFUN |bpExit| ()
(AND (|bpAssign|)
- (OR (AND (|bpEqKey| 'EXIT) (OR (|bpWhere|) (|bpTrap|))
- (|bpPush| (|bfExit| (|bpPop2|) (|bpPop1|))))
- T)))
+ (OR
+ (AND (|bpEqKey| 'EXIT) (OR (|bpWhere|) (|bpTrap|))
+ (|bpPush| (|bfExit| (|bpPop2|) (|bpPop1|))))
+ T)))
(DEFUN |bpDefinition| ()
(PROG (|a|)
(RETURN
- (COND
- ((|bpEqKey| 'MACRO)
- (OR (AND (|bpName|) (|bpStoreName|)
- (|bpCompoundDefinitionTail| #'|%Macro|))
- (|bpTrap|)))
- (T (SETQ |a| (|bpState|))
- (COND
- ((|bpExit|)
- (COND
- ((|bpEqPeek| 'DEF) (|bpRestore| |a|) (|bpDef|))
- ((|bpEqPeek| 'TDEF) (|bpRestore| |a|)
- (|bpTypeAliasDefition|))
- (T T)))
- (T (|bpRestore| |a|) NIL)))))))
+ (COND
+ ((|bpEqKey| 'MACRO)
+ (OR
+ (AND (|bpName|) (|bpStoreName|)
+ (|bpCompoundDefinitionTail| #'|%Macro|))
+ (|bpTrap|)))
+ (T (SETQ |a| (|bpState|))
+ (COND
+ ((|bpExit|)
+ (COND ((|bpEqPeek| 'DEF) (|bpRestore| |a|) (|bpDef|))
+ ((|bpEqPeek| 'TDEF) (|bpRestore| |a|) (|bpTypeAliasDefition|))
+ (T T)))
+ (T (|bpRestore| |a|) NIL)))))))
(DEFUN |bpStoreName| ()
- (DECLARE (SPECIAL |$typings| |$wheredefs| |$op| |$stack|))
+ (DECLARE (SPECIAL |$stack| |$op| |$wheredefs| |$typings|))
(PROGN
- (SETQ |$op| (CAR |$stack|))
- (SETQ |$wheredefs| NIL)
- (SETQ |$typings| NIL)
- T))
+ (SETQ |$op| (CAR |$stack|))
+ (SETQ |$wheredefs| NIL)
+ (SETQ |$typings| NIL)
+ T))
(DEFUN |bpDef| ()
(AND (|bpName|) (|bpStoreName|) (|bpDefTail| #'|%Definition|)))
@@ -964,24 +901,22 @@
(DEFUN |bpWhere| ()
(AND (|bpDefinition|)
- (OR (AND (|bpEqKey| 'WHERE) (OR (|bpDefinitionItem|) (|bpTrap|))
- (|bpPush| (|bfWhere| (|bpPop1|) (|bpPop1|))))
- T)))
+ (OR
+ (AND (|bpEqKey| 'WHERE) (OR (|bpDefinitionItem|) (|bpTrap|))
+ (|bpPush| (|bfWhere| (|bpPop1|) (|bpPop1|))))
+ T)))
(DEFUN |bpDefinitionItem| ()
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (|bpState|))
- (COND
- ((|bpDDef|) T)
- (T (|bpRestore| |a|)
- (COND
- ((|bpBDefinitionPileItems|) T)
- (T (|bpRestore| |a|)
- (COND
- ((|bpPDefinitionItems|) T)
- (T (|bpRestore| |a|) (|bpWhere|)))))))))))
+ (PROGN
+ (SETQ |a| (|bpState|))
+ (COND ((|bpDDef|) T)
+ (T (|bpRestore| |a|)
+ (COND ((|bpBDefinitionPileItems|) T)
+ (T (|bpRestore| |a|)
+ (COND ((|bpPDefinitionItems|) T)
+ (T (|bpRestore| |a|) (|bpWhere|)))))))))))
(DEFUN |bpDefinitionPileItems| ()
(AND (|bpListAndRecover| #'|bpDefinitionItem|)
@@ -993,23 +928,18 @@
(DEFUN |bpSemiColonDefinition| ()
(|bpSemiListing| #'|bpDefinitionItem| #'|%Pile|))
-(DEFUN |bpPDefinitionItems| ()
- (|bpParenthesized| #'|bpSemiColonDefinition|))
+(DEFUN |bpPDefinitionItems| () (|bpParenthesized| #'|bpSemiColonDefinition|))
(DEFUN |bpComma| ()
- (OR (|bpModule|) (|bpImport|) (|bpNamespace|)
- (|bpTuple| #'|bpWhere|)))
+ (OR (|bpModule|) (|bpImport|) (|bpNamespace|) (|bpTuple| #'|bpWhere|)))
-(DEFUN |bpTuple| (|p|)
- (|bpListofFun| |p| #'|bpCommaBackSet| #'|bfTuple|))
+(DEFUN |bpTuple| (|p|) (|bpListofFun| |p| #'|bpCommaBackSet| #'|bfTuple|))
-(DEFUN |bpCommaBackSet| ()
- (AND (|bpEqKey| 'COMMA) (OR (|bpEqKey| 'BACKSET) T)))
+(DEFUN |bpCommaBackSet| () (AND (|bpEqKey| 'COMMA) (OR (|bpEqKey| 'BACKSET) T)))
(DEFUN |bpSemiColon| () (|bpSemiListing| #'|bpComma| #'|bfSequence|))
-(DEFUN |bpSemiListing| (|p| |f|)
- (|bpListofFun| |p| #'|bpSemiBackSet| |f|))
+(DEFUN |bpSemiListing| (|p| |f|) (|bpListofFun| |p| #'|bpSemiBackSet| |f|))
(DEFUN |bpSemiBackSet| ()
(AND (|bpEqKey| 'SEMICOLON) (OR (|bpEqKey| 'BACKSET) T)))
@@ -1022,39 +952,39 @@
(DEFUN |bpBPileDefinition| () (|bpPileBracketed| #'|bpPileItems|))
-(DEFUN |bpIteratorTail| ()
- (AND (OR (|bpEqKey| 'REPEAT) T) (|bpIterators|)))
+(DEFUN |bpIteratorTail| () (AND (OR (|bpEqKey| 'REPEAT) T) (|bpIterators|)))
(DEFUN |bpConstruct| () (|bpBracket| #'|bpConstruction|))
(DEFUN |bpConstruction| ()
(AND (|bpComma|)
- (OR (AND (|bpIteratorTail|)
- (|bpPush| (|bfCollect| (|bpPop2|) (|bpPop1|))))
- (|bpPush| (|bfTupleConstruct| (|bpPop1|))))))
+ (OR
+ (AND (|bpIteratorTail|) (|bpPush| (|bfCollect| (|bpPop2|) (|bpPop1|))))
+ (|bpPush| (|bfTupleConstruct| (|bpPop1|))))))
(DEFUN |bpDConstruct| () (|bpBracket| #'|bpDConstruction|))
(DEFUN |bpDConstruction| ()
(AND (|bpComma|)
- (OR (AND (|bpIteratorTail|)
- (|bpPush| (|bfDCollect| (|bpPop2|) (|bpPop1|))))
- (|bpPush| (|bfDTuple| (|bpPop1|))))))
+ (OR
+ (AND (|bpIteratorTail|)
+ (|bpPush| (|bfDCollect| (|bpPop2|) (|bpPop1|))))
+ (|bpPush| (|bfDTuple| (|bpPop1|))))))
(DEFUN |bpPattern| ()
(OR (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) (|bpConstTok|)))
(DEFUN |bpEqual| ()
- (AND (|bpEqKey| 'SHOEEQ)
- (OR (|bpApplication|) (|bpConstTok|) (|bpTrap|))
+ (AND (|bpEqKey| 'SHOEEQ) (OR (|bpApplication|) (|bpConstTok|) (|bpTrap|))
(|bpPush| (|bfEqual| (|bpPop1|)))))
(DEFUN |bpRegularPatternItem| ()
(OR (|bpEqual|) (|bpConstTok|) (|bpDot|)
(AND (|bpName|)
- (OR (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|))
- (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))
- T))
+ (OR
+ (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|))
+ (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))
+ T))
(|bpBracketConstruct| #'|bpPatternL|)))
(DEFUN |bpRegularPatternItemL| ()
@@ -1072,37 +1002,40 @@
(DEFUN |bpPatternList| ()
(COND
- ((|bpRegularPatternItemL|)
- (LOOP
- (COND
- ((NOT (AND (|bpEqKey| 'COMMA)
- (OR (|bpRegularPatternItemL|)
- (PROGN
- (OR (AND (|bpPatternTail|)
- (|bpPush|
- (|append| (|bpPop2|) (|bpPop1|))))
- (|bpTrap|))
- NIL))))
- (RETURN NIL))
- (T (|bpPush| (|append| (|bpPop2|) (|bpPop1|))))))
- T)
- (T (|bpPatternTail|))))
+ ((|bpRegularPatternItemL|)
+ (LOOP
+ (COND
+ ((NOT
+ (AND (|bpEqKey| 'COMMA)
+ (OR (|bpRegularPatternItemL|)
+ (PROGN
+ (OR
+ (AND (|bpPatternTail|)
+ (|bpPush| (|append| (|bpPop2|) (|bpPop1|))))
+ (|bpTrap|))
+ NIL))))
+ (RETURN NIL))
+ (T (|bpPush| (|append| (|bpPop2|) (|bpPop1|))))))
+ T)
+ (T (|bpPatternTail|))))
(DEFUN |bpPatternTail| ()
(AND (|bpPatternColon|)
- (OR (AND (|bpEqKey| 'COMMA) (OR (|bpRegularList|) (|bpTrap|))
- (|bpPush| (|append| (|bpPop2|) (|bpPop1|))))
- T)))
+ (OR
+ (AND (|bpEqKey| 'COMMA) (OR (|bpRegularList|) (|bpTrap|))
+ (|bpPush| (|append| (|bpPop2|) (|bpPop1|))))
+ T)))
(DEFUN |bpRegularBVItemTail| ()
- (OR (AND (|bpEqKey| 'COLON) (OR (|bpApplication|) (|bpTrap|))
- (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|))))
- (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|))
- (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))
- (AND (|bpEqKey| 'IS) (OR (|bpPattern|) (|bpTrap|))
- (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))
- (AND (|bpEqKey| 'DEF) (OR (|bpApplication|) (|bpTrap|))
- (|bpPush| (|%DefaultValue| (|bpPop2|) (|bpPop1|))))))
+ (OR
+ (AND (|bpEqKey| 'COLON) (OR (|bpApplication|) (|bpTrap|))
+ (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|))))
+ (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|))
+ (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))
+ (AND (|bpEqKey| 'IS) (OR (|bpPattern|) (|bpTrap|))
+ (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))
+ (AND (|bpEqKey| 'DEF) (OR (|bpApplication|) (|bpTrap|))
+ (|bpPush| (|%DefaultValue| (|bpPop2|) (|bpPop1|))))))
(DEFUN |bpRegularBVItem| ()
(OR (|bpBVString|) (|bpConstTok|)
@@ -1110,7 +1043,7 @@
(|bpBracketConstruct| #'|bpPatternL|)))
(DEFUN |bpBVString| ()
- (DECLARE (SPECIAL |$ttok| |$stok|))
+ (DECLARE (SPECIAL |$stok| |$ttok|))
(AND (EQ (|shoeTokType| |$stok|) 'STRING)
(|bpPush| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext|)))
@@ -1122,54 +1055,53 @@
(DEFUN |bpBoundVariablelist| ()
(COND
- ((|bpRegularBVItemL|)
- (LOOP
- (COND
- ((NOT (AND (|bpEqKey| 'COMMA)
- (OR (|bpRegularBVItemL|)
- (PROGN
- (OR (AND (|bpColonName|)
- (|bpPush|
- (|bfColonAppend| (|bpPop2|)
- (|bpPop1|))))
- (|bpTrap|))
- NIL))))
- (RETURN NIL))
- (T (|bpPush| (|append| (|bpPop2|) (|bpPop1|))))))
- T)
- (T (AND (|bpColonName|)
- (|bpPush| (|bfColonAppend| NIL (|bpPop1|)))))))
+ ((|bpRegularBVItemL|)
+ (LOOP
+ (COND
+ ((NOT
+ (AND (|bpEqKey| 'COMMA)
+ (OR (|bpRegularBVItemL|)
+ (PROGN
+ (OR
+ (AND (|bpColonName|)
+ (|bpPush| (|bfColonAppend| (|bpPop2|) (|bpPop1|))))
+ (|bpTrap|))
+ NIL))))
+ (RETURN NIL))
+ (T (|bpPush| (|append| (|bpPop2|) (|bpPop1|))))))
+ T)
+ (T (AND (|bpColonName|) (|bpPush| (|bfColonAppend| NIL (|bpPop1|)))))))
(DEFUN |bpVariable| ()
- (OR (AND (|bpParenthesized| #'|bpBoundVariablelist|)
- (|bpPush| (|bfTupleIf| (|bpPop1|))))
- (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) (|bpConstTok|)))
+ (OR
+ (AND (|bpParenthesized| #'|bpBoundVariablelist|)
+ (|bpPush| (|bfTupleIf| (|bpPop1|))))
+ (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) (|bpConstTok|)))
(DEFUN |bpAssignVariable| ()
(OR (|bpBracketConstruct| #'|bpPatternL|) (|bpAssignLHS|)))
(DEFUN |bpAssignLHS| ()
- (COND
- ((NOT (|bpName|)) NIL)
- ((|bpEqKey| 'COLON) (OR (|bpApplication|) (|bpTrap|))
- (|bpPush| (|bfLocal| (|bpPop2|) (|bpPop1|))))
- (T (AND (|bpArgumentList|)
- (OR (|bpEqPeek| 'DOT)
- (AND (|bpEqPeek| 'BEC)
- (|bpPush| (|bfPlace| (|bpPop1|))))
- (|bpTrap|)))
- (COND
- ((|bpEqKey| 'DOT)
- (AND (|bpList| #'|bpPrimary| 'DOT) (|bpChecknull|)
- (|bpPush| (|bfTuple| (CONS (|bpPop2|) (|bpPop1|))))))
- (T T)))))
+ (COND ((NOT (|bpName|)) NIL)
+ ((|bpEqKey| 'COLON) (OR (|bpApplication|) (|bpTrap|))
+ (|bpPush| (|bfLocal| (|bpPop2|) (|bpPop1|))))
+ (T
+ (AND (|bpArgumentList|)
+ (OR (|bpEqPeek| 'DOT)
+ (AND (|bpEqPeek| 'BEC) (|bpPush| (|bfPlace| (|bpPop1|))))
+ (|bpTrap|)))
+ (COND
+ ((|bpEqKey| 'DOT)
+ (AND (|bpList| #'|bpPrimary| 'DOT) (|bpChecknull|)
+ (|bpPush| (|bfTuple| (CONS (|bpPop2|) (|bpPop1|))))))
+ (T T)))))
(DEFUN |bpChecknull| ()
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (|bpPop1|))
- (COND ((NULL |a|) (|bpTrap|)) (T (|bpPush| |a|)))))))
+ (PROGN
+ (SETQ |a| (|bpPop1|))
+ (COND ((NULL |a|) (|bpTrap|)) (T (|bpPush| |a|)))))))
(DEFUN |bpStruct| ()
(AND (|bpEqKey| 'STRUCTURE) (OR (|bpName|) (|bpTrap|))
@@ -1185,12 +1117,13 @@
(DEFUN |bpTypeItemList| () (|bpListAndRecover| #'|bpTypeItem|))
(DEFUN |bpTerm| (|idListParser|)
- (OR (AND (OR (|bpName|) (|bpTrap|))
- (OR (AND (|bpParenthesized| |idListParser|)
- (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|))))
- (AND (|bpName|)
- (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|))))))
- (|bpPush| (|bfNameOnly| (|bpPop1|)))))
+ (OR
+ (AND (OR (|bpName|) (|bpTrap|))
+ (OR
+ (AND (|bpParenthesized| |idListParser|)
+ (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|))))
+ (AND (|bpName|) (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|))))))
+ (|bpPush| (|bfNameOnly| (|bpPop1|)))))
(DEFUN |bpIdList| () (|bpTuple| #'|bpName|))
@@ -1215,29 +1148,26 @@
(DEFUN |bpOutItem| ()
(PROG (|$GenVarCounter| |$op| |r| |ISTMP#2| |l| |ISTMP#1| |b|)
- (DECLARE (SPECIAL |$GenVarCounter| |$op| |$InteractiveMode|))
+ (DECLARE (SPECIAL |$op| |$GenVarCounter| |$InteractiveMode|))
(RETURN
- (PROGN
- (SETQ |$op| NIL)
- (SETQ |$GenVarCounter| 0)
- (OR (|bpComma|) (|bpTrap|))
- (SETQ |b| (|bpPop1|))
- (|bpPush|
- (COND
- ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|))
- ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T)
- (PROGN
- (SETQ |ISTMP#1| (CDR |b|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |l| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))
- (SYMBOLP |l|))
- (COND
- (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|)))
- (T (LIST (LIST 'DEFPARAMETER |l| |r|)))))
- (T (|translateToplevel| |b| NIL))))))))
+ (PROGN
+ (SETQ |$op| NIL)
+ (SETQ |$GenVarCounter| 0)
+ (OR (|bpComma|) (|bpTrap|))
+ (SETQ |b| (|bpPop1|))
+ (|bpPush|
+ (COND ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|))
+ ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |b|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |l| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |r| (CAR |ISTMP#2|)) T)))))
+ (SYMBOLP |l|))
+ (COND (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|)))
+ (T (LIST (LIST 'DEFPARAMETER |l| |r|)))))
+ (T (|translateToplevel| |b| NIL))))))))
diff --git a/src/boot/strap/pile.clisp b/src/boot/strap/pile.clisp
index 934e6728..eb3ea075 100644
--- a/src/boot/strap/pile.clisp
+++ b/src/boot/strap/pile.clisp
@@ -16,136 +16,118 @@
(DEFUN |shoePileInsert| (|s|)
(PROG (|a| |toktype|)
(RETURN
- (COND
- ((|bStreamNull| |s|) (CONS NIL |s|))
- (T (SETQ |toktype| (|shoeTokType| (CAAAR |s|)))
- (COND
+ (COND ((|bStreamNull| |s|) (CONS NIL |s|))
+ (T (SETQ |toktype| (|shoeTokType| (CAAAR |s|)))
+ (COND
((OR (EQ |toktype| 'LISP) (EQ |toktype| 'LINE))
(CONS (LIST (CAR |s|)) (CDR |s|)))
(T (SETQ |a| (|shoePileTree| (- 1) |s|))
- (CONS (LIST (ELT |a| 2)) (ELT |a| 3)))))))))
+ (CONS (LIST (ELT |a| 2)) (ELT |a| 3)))))))))
(DEFUN |shoePileTree| (|n| |s|)
(PROG (|hh| |t| |h| |LETTMP#1|)
(RETURN
- (COND
- ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
- (T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
- (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
- (SETQ |hh| (|shoePileColumn| |h|))
- (COND
- ((< |n| |hh|) (|shoePileForests| |h| |hh| |t|))
- (T (LIST NIL |n| NIL |s|))))))))
+ (COND ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
+ (T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
+ (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
+ (SETQ |hh| (|shoePileColumn| |h|))
+ (COND ((< |n| |hh|) (|shoePileForests| |h| |hh| |t|))
+ (T (LIST NIL |n| NIL |s|))))))))
(DEFUN |eqshoePileTree| (|n| |s|)
(PROG (|hh| |t| |h| |LETTMP#1|)
(RETURN
- (COND
- ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
- (T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
- (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
- (SETQ |hh| (|shoePileColumn| |h|))
- (COND
- ((EQUAL |hh| |n|) (|shoePileForests| |h| |hh| |t|))
- (T (LIST NIL |n| NIL |s|))))))))
+ (COND ((|bStreamNull| |s|) (LIST NIL |n| NIL |s|))
+ (T (SETQ |LETTMP#1| (LIST (CAR |s|) (CDR |s|)))
+ (SETQ |h| (CAR |LETTMP#1|)) (SETQ |t| (CADR |LETTMP#1|))
+ (SETQ |hh| (|shoePileColumn| |h|))
+ (COND ((EQUAL |hh| |n|) (|shoePileForests| |h| |hh| |t|))
+ (T (LIST NIL |n| NIL |s|))))))))
(DEFUN |shoePileForest| (|n| |s|)
(PROG (|t1| |h1| |t| |h| |hh| |b| |LETTMP#1|)
(RETURN
- (PROGN
- (SETQ |LETTMP#1| (|shoePileTree| |n| |s|))
- (SETQ |b| (CAR |LETTMP#1|))
- (SETQ |hh| (CADR . #0=(|LETTMP#1|)))
- (SETQ |h| (CADDR . #0#))
- (SETQ |t| (CADDDR . #0#))
- (COND
- (|b| (SETQ |LETTMP#1| (|shoePileForest1| |hh| |t|))
- (SETQ |h1| (CAR |LETTMP#1|))
- (SETQ |t1| (CADR |LETTMP#1|))
- (LIST (CONS |h| |h1|) |t1|))
- (T (LIST NIL |s|)))))))
+ (PROGN
+ (SETQ |LETTMP#1| (|shoePileTree| |n| |s|))
+ (SETQ |b| (CAR |LETTMP#1|))
+ (SETQ |hh| (CADR . #1=(|LETTMP#1|)))
+ (SETQ |h| (CADDR . #1#))
+ (SETQ |t| (CADDDR . #1#))
+ (COND
+ (|b| (SETQ |LETTMP#1| (|shoePileForest1| |hh| |t|))
+ (SETQ |h1| (CAR |LETTMP#1|)) (SETQ |t1| (CADR |LETTMP#1|))
+ (LIST (CONS |h| |h1|) |t1|))
+ (T (LIST NIL |s|)))))))
(DEFUN |shoePileForest1| (|n| |s|)
(PROG (|t1| |h1| |t| |h| |n1| |b| |LETTMP#1|)
(RETURN
- (PROGN
- (SETQ |LETTMP#1| (|eqshoePileTree| |n| |s|))
- (SETQ |b| (CAR |LETTMP#1|))
- (SETQ |n1| (CADR . #0=(|LETTMP#1|)))
- (SETQ |h| (CADDR . #0#))
- (SETQ |t| (CADDDR . #0#))
- (COND
- (|b| (SETQ |LETTMP#1| (|shoePileForest1| |n| |t|))
- (SETQ |h1| (CAR |LETTMP#1|))
- (SETQ |t1| (CADR |LETTMP#1|))
- (LIST (CONS |h| |h1|) |t1|))
- (T (LIST NIL |s|)))))))
+ (PROGN
+ (SETQ |LETTMP#1| (|eqshoePileTree| |n| |s|))
+ (SETQ |b| (CAR |LETTMP#1|))
+ (SETQ |n1| (CADR . #1=(|LETTMP#1|)))
+ (SETQ |h| (CADDR . #1#))
+ (SETQ |t| (CADDDR . #1#))
+ (COND
+ (|b| (SETQ |LETTMP#1| (|shoePileForest1| |n| |t|))
+ (SETQ |h1| (CAR |LETTMP#1|)) (SETQ |t1| (CADR |LETTMP#1|))
+ (LIST (CONS |h| |h1|) |t1|))
+ (T (LIST NIL |s|)))))))
(DEFUN |shoePileForests| (|h| |n| |s|)
(PROG (|t1| |h1| |LETTMP#1|)
(RETURN
- (PROGN
- (SETQ |LETTMP#1| (|shoePileForest| |n| |s|))
- (SETQ |h1| (CAR |LETTMP#1|))
- (SETQ |t1| (CADR |LETTMP#1|))
- (COND
- ((|bStreamNull| |h1|) (LIST T |n| |h| |s|))
- (T (|shoePileForests| (|shoePileCtree| |h| |h1|) |n| |t1|)))))))
+ (PROGN
+ (SETQ |LETTMP#1| (|shoePileForest| |n| |s|))
+ (SETQ |h1| (CAR |LETTMP#1|))
+ (SETQ |t1| (CADR |LETTMP#1|))
+ (COND ((|bStreamNull| |h1|) (LIST T |n| |h| |s|))
+ (T (|shoePileForests| (|shoePileCtree| |h| |h1|) |n| |t1|)))))))
-(DEFUN |shoePileCtree| (|x| |y|)
- (|dqAppend| |x| (|shoePileCforest| |y|)))
+(DEFUN |shoePileCtree| (|x| |y|) (|dqAppend| |x| (|shoePileCforest| |y|)))
(DEFUN |shoePileCforest| (|x|)
(PROG (|b| |a|)
(RETURN
- (COND
- ((NULL |x|) NIL)
- ((NULL (CDR |x|)) (CAR |x|))
- (T (SETQ |a| (CAR |x|))
- (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|)))
- (COND
- ((NULL (CDR |b|)) (CAR |b|))
- (T (|shoeEnPile| (|shoeSeparatePiles| |b|)))))))))
+ (COND ((NULL |x|) NIL) ((NULL (CDR |x|)) (CAR |x|))
+ (T (SETQ |a| (CAR |x|))
+ (SETQ |b| (|shoePileCoagulate| |a| (CDR |x|)))
+ (COND ((NULL (CDR |b|)) (CAR |b|))
+ (T (|shoeEnPile| (|shoeSeparatePiles| |b|)))))))))
(DEFUN |shoePileCoagulate| (|a| |b|)
(PROG (|e| |d| |c|)
(RETURN
- (COND
- ((NULL |b|) (LIST |a|))
- (T (SETQ |c| (CAR |b|))
- (COND
+ (COND ((NULL |b|) (LIST |a|))
+ (T (SETQ |c| (CAR |b|))
+ (COND
((OR (EQ (|shoeTokPart| (CAAR |c|)) 'THEN)
(EQ (|shoeTokPart| (CAAR |c|)) 'ELSE))
(|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
(T (SETQ |d| (CADR |a|)) (SETQ |e| (|shoeTokPart| |d|))
- (COND
- ((AND (CONSP |d|) (EQ (CAR |d|) 'KEY)
- (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA)
- (EQ |e| 'SEMICOLON)))
- (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
- (T (CONS |a| (|shoePileCoagulate| |c| (CDR |b|))))))))))))
+ (COND
+ ((AND (CONSP |d|) (EQ (CAR |d|) 'KEY)
+ (OR (GET |e| 'SHOEINF) (EQ |e| 'COMMA)
+ (EQ |e| 'SEMICOLON)))
+ (|shoePileCoagulate| (|dqAppend| |a| |c|) (CDR |b|)))
+ (T (CONS |a| (|shoePileCoagulate| |c| (CDR |b|))))))))))))
(DEFUN |shoeSeparatePiles| (|x|)
(PROG (|semicolon| |a|)
(RETURN
- (COND
- ((NULL |x|) NIL)
- ((NULL (CDR |x|)) (CAR |x|))
- (T (SETQ |a| (CAR |x|))
- (SETQ |semicolon|
- (|dqUnit|
+ (COND ((NULL |x|) NIL) ((NULL (CDR |x|)) (CAR |x|))
+ (T (SETQ |a| (CAR |x|))
+ (SETQ |semicolon|
+ (|dqUnit|
(|shoeTokConstruct| 'KEY 'BACKSET
- (|shoeLastTokPosn| |a|))))
- (|dqConcat|
- (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|)))))))))
+ (|shoeLastTokPosn| |a|))))
+ (|dqConcat|
+ (LIST |a| |semicolon| (|shoeSeparatePiles| (CDR |x|)))))))))
(DEFUN |shoeEnPile| (|x|)
(|dqConcat|
- (LIST (|dqUnit|
- (|shoeTokConstruct| 'KEY 'SETTAB
- (|shoeFirstTokPosn| |x|)))
- |x|
- (|dqUnit|
- (|shoeTokConstruct| 'KEY 'BACKTAB
- (|shoeLastTokPosn| |x|))))))
+ (LIST (|dqUnit| (|shoeTokConstruct| 'KEY 'SETTAB (|shoeFirstTokPosn| |x|)))
+ |x|
+ (|dqUnit|
+ (|shoeTokConstruct| 'KEY 'BACKTAB (|shoeLastTokPosn| |x|))))))
diff --git a/src/boot/strap/scanner.clisp b/src/boot/strap/scanner.clisp
index 02b7f8c6..78c63d07 100644
--- a/src/boot/strap/scanner.clisp
+++ b/src/boot/strap/scanner.clisp
@@ -15,16 +15,12 @@
(PROG (|a|) (RETURN (PROGN (SETQ |a| (LIST |s|)) (CONS |a| |a|)))))
(DEFUN |dqAppend| (|x| |y|)
- (COND
- ((NULL |x|) |y|)
- ((NULL |y|) |x|)
- (T (RPLACD (CDR |x|) (CAR |y|)) (RPLACD |x| (CDR |y|)) |x|)))
+ (COND ((NULL |x|) |y|) ((NULL |y|) |x|)
+ (T (RPLACD (CDR |x|) (CAR |y|)) (RPLACD |x| (CDR |y|)) |x|)))
(DEFUN |dqConcat| (|ld|)
- (COND
- ((NULL |ld|) NIL)
- ((NULL (CDR |ld|)) (CAR |ld|))
- (T (|dqAppend| (CAR |ld|) (|dqConcat| (CDR |ld|))))))
+ (COND ((NULL |ld|) NIL) ((NULL (CDR |ld|)) (CAR |ld|))
+ (T (|dqAppend| (CAR |ld|) (|dqConcat| (CDR |ld|))))))
(DEFUN |dqToList| (|s|) (COND ((NULL |s|) NIL) (T (CAR |s|))))
@@ -41,132 +37,120 @@
(DEFUN |shoeNextLine| (|s|)
(PROG (|s1| |a|)
- (DECLARE (SPECIAL |$sz| |$n| |$ln| |$r| |$f| |$linepos|))
+ (DECLARE (SPECIAL |$linepos| |$f| |$r| |$ln| |$n| |$sz|))
(RETURN
- (COND
- ((|bStreamNull| |s|) NIL)
- (T (SETQ |$linepos| |s|) (SETQ |$f| (CAR |s|))
- (SETQ |$r| (CDR |s|)) (SETQ |$ln| (CAR |$f|))
- (SETQ |$n| (STRPOSL " " |$ln| 0 T))
- (SETQ |$sz| (LENGTH |$ln|))
- (COND
- ((NULL |$n|) T)
- ((CHAR= (SCHAR |$ln| |$n|) |shoeTAB|)
- (SETQ |a|
- (|makeString| (- 7 (REM |$n| 8)) (|char| '| |)))
- (SETF (SCHAR |$ln| |$n|) (|char| '| |))
- (SETQ |$ln| (CONCAT |a| |$ln|))
- (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|))
- (|shoeNextLine| |s1|))
- (T T)))))))
+ (COND ((|bStreamNull| |s|) NIL)
+ (T (SETQ |$linepos| |s|) (SETQ |$f| (CAR |s|)) (SETQ |$r| (CDR |s|))
+ (SETQ |$ln| (CAR |$f|)) (SETQ |$n| (STRPOSL " " |$ln| 0 T))
+ (SETQ |$sz| (LENGTH |$ln|))
+ (COND ((NULL |$n|) T)
+ ((CHAR= (SCHAR |$ln| |$n|) |shoeTAB|)
+ (SETQ |a| (|makeString| (- 7 (REM |$n| 8)) (|char| '| |)))
+ (SETF (SCHAR |$ln| |$n|) (|char| '| |))
+ (SETQ |$ln| (CONCAT |a| |$ln|))
+ (SETQ |s1| (CONS (CONS |$ln| (CDR |$f|)) |$r|))
+ (|shoeNextLine| |s1|))
+ (T T)))))))
(DEFUN |shoeLineToks| (|s|)
(PROG (|$linepos| |$floatok| |$sz| |$n| |$ln| |$r| |$f| |toks| |dq|
- |command|)
- (DECLARE (SPECIAL |$floatok| |$f| |$sz| |$linepos| |$ln| |$r| |$n|))
+ |command|)
+ (DECLARE (SPECIAL |$f| |$floatok| |$sz| |$linepos| |$ln| |$r| |$n|))
(RETURN
- (PROGN
- (SETQ |$f| NIL)
- (SETQ |$r| NIL)
- (SETQ |$ln| NIL)
- (SETQ |$n| NIL)
- (SETQ |$sz| NIL)
- (SETQ |$floatok| T)
- (SETQ |$linepos| |s|)
- (COND
- ((NOT (|shoeNextLine| |s|)) (CONS NIL NIL))
- ((NULL |$n|) (|shoeLineToks| |$r|))
- ((CHAR= (SCHAR |$ln| 0) (|char| '|)|))
- (COND
- ((SETQ |command| (|shoeLine?| |$ln|))
- (SETQ |dq|
- (|dqUnit|
+ (PROGN
+ (SETQ |$f| NIL)
+ (SETQ |$r| NIL)
+ (SETQ |$ln| NIL)
+ (SETQ |$n| NIL)
+ (SETQ |$sz| NIL)
+ (SETQ |$floatok| T)
+ (SETQ |$linepos| |s|)
+ (COND ((NOT (|shoeNextLine| |s|)) (CONS NIL NIL))
+ ((NULL |$n|) (|shoeLineToks| |$r|))
+ ((CHAR= (SCHAR |$ln| 0) (|char| '|)|))
+ (COND
+ ((SETQ |command| (|shoeLine?| |$ln|))
+ (SETQ |dq|
+ (|dqUnit|
(|shoeConstructToken| |$linepos|
- (|shoeLeafLine| |command|) 0)))
- (CONS (LIST |dq|) |$r|))
- ((SETQ |command| (|shoeLisp?| |$ln|))
- (|shoeLispToken| |$r| |command|))
- (T (|shoeLineToks| |$r|))))
- (T (SETQ |toks| NIL)
+ (|shoeLeafLine| |command|) 0)))
+ (CONS (LIST |dq|) |$r|))
+ ((SETQ |command| (|shoeLisp?| |$ln|))
+ (|shoeLispToken| |$r| |command|))
+ (T (|shoeLineToks| |$r|))))
+ (T (SETQ |toks| NIL)
(LOOP
- (COND
- ((NOT (< |$n| |$sz|)) (RETURN NIL))
- (T (SETQ |toks| (|dqAppend| |toks| (|shoeToken|))))))
- (COND
- ((NULL |toks|) (|shoeLineToks| |$r|))
- (T (CONS (LIST |toks|) |$r|)))))))))
+ (COND ((NOT (< |$n| |$sz|)) (RETURN NIL))
+ (T (SETQ |toks| (|dqAppend| |toks| (|shoeToken|))))))
+ (COND ((NULL |toks|) (|shoeLineToks| |$r|))
+ (T (CONS (LIST |toks|) |$r|)))))))))
(DEFUN |shoeLispToken| (|s| |string|)
(PROG (|dq| |st| |r| |LETTMP#1| |linepos| |ln|)
- (DECLARE (SPECIAL |$linepos| |$ln|))
+ (DECLARE (SPECIAL |$ln| |$linepos|))
(RETURN
- (PROGN
- (COND
- ((OR (EQL (LENGTH |string|) 0)
- (CHAR= (SCHAR |string| 0) (|char| '|;|)))
- (SETQ |string| "")))
- (SETQ |ln| |$ln|)
- (SETQ |linepos| |$linepos|)
- (SETQ |LETTMP#1| (|shoeAccumulateLines| |s| |string|))
- (SETQ |r| (CAR |LETTMP#1|))
- (SETQ |st| (CDR |LETTMP#1|))
- (SETQ |dq|
+ (PROGN
+ (COND
+ ((OR (EQL (LENGTH |string|) 0) (CHAR= (SCHAR |string| 0) (|char| '|;|)))
+ (SETQ |string| "")))
+ (SETQ |ln| |$ln|)
+ (SETQ |linepos| |$linepos|)
+ (SETQ |LETTMP#1| (|shoeAccumulateLines| |s| |string|))
+ (SETQ |r| (CAR |LETTMP#1|))
+ (SETQ |st| (CDR |LETTMP#1|))
+ (SETQ |dq|
(|dqUnit|
- (|shoeConstructToken| |linepos| (|shoeLeafLisp| |st|)
- 0)))
- (CONS (LIST |dq|) |r|)))))
+ (|shoeConstructToken| |linepos| (|shoeLeafLisp| |st|) 0)))
+ (CONS (LIST |dq|) |r|)))))
(DEFUN |shoeAccumulateLines| (|s| |string|)
(PROG (|a| |command|)
- (DECLARE (SPECIAL |$ln| |$r| |$n|))
+ (DECLARE (SPECIAL |$n| |$r| |$ln|))
(RETURN
- (COND
- ((NOT (|shoeNextLine| |s|)) (CONS |s| |string|))
- ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|))
- ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|))
- ((CHAR= (SCHAR |$ln| 0) (|char| '|)|))
- (SETQ |command| (|shoeLisp?| |$ln|))
- (COND
- ((AND |command| (PLUSP (LENGTH |command|)))
+ (COND ((NOT (|shoeNextLine| |s|)) (CONS |s| |string|))
+ ((NULL |$n|) (|shoeAccumulateLines| |$r| |string|))
+ ((EQL (LENGTH |$ln|) 0) (|shoeAccumulateLines| |$r| |string|))
+ ((CHAR= (SCHAR |$ln| 0) (|char| '|)|))
+ (SETQ |command| (|shoeLisp?| |$ln|))
(COND
- ((CHAR= (SCHAR |command| 0) (|char| '|;|))
- (|shoeAccumulateLines| |$r| |string|))
- ((SETQ |a| (|charPosition| (|char| '|;|) |command| 0))
- (|shoeAccumulateLines| |$r|
- (CONCAT |string|
- (|subString| |command| 0 (- |a| 1)))))
- (T (|shoeAccumulateLines| |$r|
- (CONCAT |string| |command|)))))
- (T (|shoeAccumulateLines| |$r| |string|))))
- (T (CONS |s| |string|))))))
+ ((AND |command| (PLUSP (LENGTH |command|)))
+ (COND
+ ((CHAR= (SCHAR |command| 0) (|char| '|;|))
+ (|shoeAccumulateLines| |$r| |string|))
+ ((SETQ |a| (|charPosition| (|char| '|;|) |command| 0))
+ (|shoeAccumulateLines| |$r|
+ (CONCAT |string|
+ (|subString| |command| 0
+ (- |a| 1)))))
+ (T (|shoeAccumulateLines| |$r| (CONCAT |string| |command|)))))
+ (T (|shoeAccumulateLines| |$r| |string|))))
+ (T (CONS |s| |string|))))))
(DEFUN |shoeCloser| (|t|)
(|symbolMember?| (|shoeKeyWord| |t|) '(CPAREN CBRACK)))
(DEFUN |shoeToken| ()
(PROG (|b| |ch| |n| |linepos|)
- (DECLARE (SPECIAL |$ln| |$n| |$linepos|))
+ (DECLARE (SPECIAL |$linepos| |$n| |$ln|))
(RETURN
- (PROGN
- (SETQ |linepos| |$linepos|)
- (SETQ |n| |$n|)
- (SETQ |ch| (SCHAR |$ln| |$n|))
- (SETQ |b|
- (COND
- ((|shoeStartsComment|) (|shoeComment|) NIL)
- ((|shoeStartsNegComment|) (|shoeNegComment|) NIL)
- ((CHAR= |ch| (|char| '!)) (|shoeLispEscape|))
- ((|shoePunctuation| (CHAR-CODE |ch|)) (|shoePunct|))
- ((|shoeStartsId| |ch|) (|shoeWord| NIL))
- ((CHAR= |ch| (|char| '| |)) (|shoeSpace|) NIL)
- ((CHAR= |ch| (|char| '|"|)) (|shoeString|))
- ((DIGIT-CHAR-P |ch|) (|shoeNumber|))
- ((CHAR= |ch| (|char| '_)) (|shoeEscape|))
- ((EQUAL |ch| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL)
- (T (|shoeError|))))
- (COND
- ((NULL |b|) NIL)
- (T (|dqUnit| (|shoeConstructToken| |linepos| |b| |n|))))))))
+ (PROGN
+ (SETQ |linepos| |$linepos|)
+ (SETQ |n| |$n|)
+ (SETQ |ch| (SCHAR |$ln| |$n|))
+ (SETQ |b|
+ (COND ((|shoeStartsComment|) (|shoeComment|) NIL)
+ ((|shoeStartsNegComment|) (|shoeNegComment|) NIL)
+ ((CHAR= |ch| (|char| '!)) (|shoeLispEscape|))
+ ((|shoePunctuation| (CHAR-CODE |ch|)) (|shoePunct|))
+ ((|shoeStartsId| |ch|) (|shoeWord| NIL))
+ ((CHAR= |ch| (|char| '| |)) (|shoeSpace|) NIL)
+ ((CHAR= |ch| (|char| '|"|)) (|shoeString|))
+ ((DIGIT-CHAR-P |ch|) (|shoeNumber|))
+ ((CHAR= |ch| (|char| '_)) (|shoeEscape|))
+ ((EQUAL |ch| |shoeTAB|) (SETQ |$n| (+ |$n| 1)) NIL)
+ (T (|shoeError|))))
+ (COND ((NULL |b|) NIL)
+ (T (|dqUnit| (|shoeConstructToken| |linepos| |b| |n|))))))))
(DEFUN |shoeLeafId| (|x|) (LIST 'ID (INTERN |x|)))
@@ -177,12 +161,10 @@
(DEFUN |shoeLeafFloat| (|a| |w| |e|)
(PROG (|c| |b|)
(RETURN
- (PROGN
- (SETQ |b| (|shoeIntValue| (CONCAT |a| |w|)))
- (SETQ |c|
- (* (|double| |b|)
- (EXPT (|double| 10) (- |e| (LENGTH |w|)))))
- (LIST 'FLOAT |c|)))))
+ (PROGN
+ (SETQ |b| (|shoeIntValue| (CONCAT |a| |w|)))
+ (SETQ |c| (* (|double| |b|) (EXPT (|double| 10) (- |e| (LENGTH |w|)))))
+ (LIST 'FLOAT |c|)))))
(DEFUN |shoeLeafString| (|x|) (LIST 'STRING |x|))
@@ -202,318 +184,288 @@
(DEFUN |shoeLispEscape| ()
(PROG (|n| |exp| |a|)
- (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$linepos| |$ln|))
(RETURN
- (PROGN
- (SETQ |$n| (+ |$n| 1))
+ (PROGN
+ (SETQ |$n| (+ |$n| 1))
+ (COND
+ ((NOT (< |$n| |$sz|))
+ (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error")
+ (|shoeLeafError| (SCHAR |$ln| |$n|)))
+ (T (SETQ |a| (|shoeReadLispString| |$ln| |$n|))
(COND
- ((NOT (< |$n| |$sz|))
- (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error")
- (|shoeLeafError| (SCHAR |$ln| |$n|)))
- (T (SETQ |a| (|shoeReadLispString| |$ln| |$n|))
- (COND
- ((NULL |a|)
- (|SoftShoeError| (CONS |$linepos| |$n|)
- "lisp escape error")
- (|shoeLeafError| (SCHAR |$ln| |$n|)))
- (T (SETQ |exp| (CAR |a|)) (SETQ |n| (CADR |a|))
- (COND
- ((NULL |n|) (SETQ |$n| |$sz|)
- (|shoeLeafLispExp| |exp|))
- (T (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|)))))))))))
+ ((NULL |a|)
+ (|SoftShoeError| (CONS |$linepos| |$n|) "lisp escape error")
+ (|shoeLeafError| (SCHAR |$ln| |$n|)))
+ (T (SETQ |exp| (CAR |a|)) (SETQ |n| (CADR |a|))
+ (COND ((NULL |n|) (SETQ |$n| |$sz|) (|shoeLeafLispExp| |exp|))
+ (T (SETQ |$n| |n|) (|shoeLeafLispExp| |exp|)))))))))))
(DEFUN |shoeEscape| ()
(DECLARE (SPECIAL |$n|))
- (PROGN
- (SETQ |$n| (+ |$n| 1))
- (COND ((|shoeEsc|) (|shoeWord| T)) (T NIL))))
+ (PROGN (SETQ |$n| (+ |$n| 1)) (COND ((|shoeEsc|) (|shoeWord| T)) (T NIL))))
(DEFUN |shoeEsc| ()
(PROG (|n1|)
- (DECLARE (SPECIAL |$ln| |$r| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$r| |$ln|))
(RETURN
- (COND
- ((NOT (< |$n| |$sz|))
- (COND
- ((|shoeNextLine| |$r|)
- (LOOP
- (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|))))
- (|shoeEsc|) NIL)
- (T NIL)))
- (T (SETQ |n1| (STRPOSL " " |$ln| |$n| T))
- (COND
- ((NULL |n1|) (|shoeNextLine| |$r|)
- (LOOP
- (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|))))
- (|shoeEsc|) NIL)
- (T T)))))))
+ (COND
+ ((NOT (< |$n| |$sz|))
+ (COND
+ ((|shoeNextLine| |$r|)
+ (LOOP (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|))))
+ (|shoeEsc|) NIL)
+ (T NIL)))
+ (T (SETQ |n1| (STRPOSL " " |$ln| |$n| T))
+ (COND
+ ((NULL |n1|) (|shoeNextLine| |$r|)
+ (LOOP (COND (|$n| (RETURN NIL)) (T (|shoeNextLine| |$r|))))
+ (|shoeEsc|) NIL)
+ (T T)))))))
(DEFUN |shoeStartsComment| ()
(PROG (|www|)
- (DECLARE (SPECIAL |$ln| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$ln|))
(RETURN
- (COND
- ((< |$n| |$sz|)
- (COND
- ((CHAR= (SCHAR |$ln| |$n|) (|char| '+))
- (SETQ |www| (+ |$n| 1))
- (COND
- ((NOT (< |www| |$sz|)) NIL)
- (T (CHAR= (SCHAR |$ln| |www|) (|char| '+)))))
- (T NIL)))
- (T NIL)))))
+ (COND
+ ((< |$n| |$sz|)
+ (COND
+ ((CHAR= (SCHAR |$ln| |$n|) (|char| '+)) (SETQ |www| (+ |$n| 1))
+ (COND ((NOT (< |www| |$sz|)) NIL)
+ (T (CHAR= (SCHAR |$ln| |www|) (|char| '+)))))
+ (T NIL)))
+ (T NIL)))))
(DEFUN |shoeStartsNegComment| ()
(PROG (|www|)
- (DECLARE (SPECIAL |$ln| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$ln|))
(RETURN
- (COND
- ((< |$n| |$sz|)
- (COND
- ((CHAR= (SCHAR |$ln| |$n|) (|char| '-))
- (SETQ |www| (+ |$n| 1))
- (COND
- ((NOT (< |www| |$sz|)) NIL)
- (T (CHAR= (SCHAR |$ln| |www|) (|char| '-)))))
- (T NIL)))
- (T NIL)))))
+ (COND
+ ((< |$n| |$sz|)
+ (COND
+ ((CHAR= (SCHAR |$ln| |$n|) (|char| '-)) (SETQ |www| (+ |$n| 1))
+ (COND ((NOT (< |www| |$sz|)) NIL)
+ (T (CHAR= (SCHAR |$ln| |www|) (|char| '-)))))
+ (T NIL)))
+ (T NIL)))))
(DEFUN |shoeNegComment| ()
(PROG (|n|)
- (DECLARE (SPECIAL |$ln| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$ln|))
(RETURN
- (PROGN
- (SETQ |n| |$n|)
- (SETQ |$n| |$sz|)
- (|shoeLeafNegComment| (|subString| |$ln| |n|))))))
+ (PROGN
+ (SETQ |n| |$n|)
+ (SETQ |$n| |$sz|)
+ (|shoeLeafNegComment| (|subString| |$ln| |n|))))))
(DEFUN |shoeComment| ()
(PROG (|n|)
- (DECLARE (SPECIAL |$ln| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$ln|))
(RETURN
- (PROGN
- (SETQ |n| |$n|)
- (SETQ |$n| |$sz|)
- (|shoeLeafComment| (|subString| |$ln| |n|))))))
+ (PROGN
+ (SETQ |n| |$n|)
+ (SETQ |$n| |$sz|)
+ (|shoeLeafComment| (|subString| |$ln| |n|))))))
(DEFUN |shoePunct| ()
(PROG (|sss|)
- (DECLARE (SPECIAL |$n| |$ln|))
+ (DECLARE (SPECIAL |$ln| |$n|))
(RETURN
- (PROGN
- (SETQ |sss| (|shoeMatch| |$ln| |$n|))
- (SETQ |$n| (+ |$n| (LENGTH |sss|)))
- (|shoeKeyTr| |sss|)))))
+ (PROGN
+ (SETQ |sss| (|shoeMatch| |$ln| |$n|))
+ (SETQ |$n| (+ |$n| (LENGTH |sss|)))
+ (|shoeKeyTr| |sss|)))))
(DEFUN |shoeKeyTr| (|w|)
(DECLARE (SPECIAL |$floatok|))
(COND
- ((EQ (|shoeKeyWord| |w|) 'DOT)
- (COND (|$floatok| (|shoePossFloat| |w|)) (T (|shoeLeafKey| |w|))))
- (T (SETQ |$floatok| (NOT (|shoeCloser| |w|))) (|shoeLeafKey| |w|))))
+ ((EQ (|shoeKeyWord| |w|) 'DOT)
+ (COND (|$floatok| (|shoePossFloat| |w|)) (T (|shoeLeafKey| |w|))))
+ (T (SETQ |$floatok| (NOT (|shoeCloser| |w|))) (|shoeLeafKey| |w|))))
(DEFUN |shoePossFloat| (|w|)
- (DECLARE (SPECIAL |$ln| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$ln|))
(COND
- ((OR (NOT (< |$n| |$sz|)) (NOT (DIGIT-CHAR-P (SCHAR |$ln| |$n|))))
- (|shoeLeafKey| |w|))
- (T (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|))))
+ ((OR (NOT (< |$n| |$sz|)) (NOT (DIGIT-CHAR-P (SCHAR |$ln| |$n|))))
+ (|shoeLeafKey| |w|))
+ (T (SETQ |w| (|shoeInteger|)) (|shoeExponent| "0" |w|))))
(DEFUN |shoeSpace| ()
(PROG (|n|)
- (DECLARE (SPECIAL |$floatok| |$ln| |$n|))
+ (DECLARE (SPECIAL |$n| |$ln| |$floatok|))
(RETURN
- (PROGN
- (SETQ |n| |$n|)
- (SETQ |$n| (STRPOSL " " |$ln| |$n| T))
- (SETQ |$floatok| T)
- (COND
- ((NULL |$n|) (|shoeLeafSpaces| 0) (SETQ |$n| (LENGTH |$ln|)))
- (T (|shoeLeafSpaces| (- |$n| |n|))))))))
+ (PROGN
+ (SETQ |n| |$n|)
+ (SETQ |$n| (STRPOSL " " |$ln| |$n| T))
+ (SETQ |$floatok| T)
+ (COND ((NULL |$n|) (|shoeLeafSpaces| 0) (SETQ |$n| (LENGTH |$ln|)))
+ (T (|shoeLeafSpaces| (- |$n| |n|))))))))
(DEFUN |shoeString| ()
- (DECLARE (SPECIAL |$floatok| |$n|))
+ (DECLARE (SPECIAL |$n| |$floatok|))
(PROGN
- (SETQ |$n| (+ |$n| 1))
- (SETQ |$floatok| NIL)
- (|shoeLeafString| (|shoeS|))))
+ (SETQ |$n| (+ |$n| 1))
+ (SETQ |$floatok| NIL)
+ (|shoeLeafString| (|shoeS|))))
(DEFUN |shoeS| ()
(PROG (|b| |a| |str| |mn| |escsym| |strsym| |n|)
- (DECLARE (SPECIAL |$ln| |$linepos| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$linepos| |$ln|))
(RETURN
- (COND
- ((NOT (< |$n| |$sz|))
- (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") "")
- (T (SETQ |n| |$n|)
- (SETQ |strsym|
- (OR (|charPosition| (|char| '|"|) |$ln| |$n|) |$sz|))
- (SETQ |escsym|
- (OR (|charPosition| (|char| '_) |$ln| |$n|) |$sz|))
- (SETQ |mn| (MIN |strsym| |escsym|))
- (COND
- ((EQUAL |mn| |$sz|) (SETQ |$n| |$sz|)
- (|SoftShoeError| (CONS |$linepos| |$n|) "quote added")
- (|subString| |$ln| |n|))
- ((EQUAL |mn| |strsym|) (SETQ |$n| (+ |mn| 1))
- (|subString| |$ln| |n| (- |mn| |n|)))
- (T (SETQ |str| (|subString| |$ln| |n| (- |mn| |n|)))
- (SETQ |$n| (+ |mn| 1)) (SETQ |a| (|shoeEsc|))
- (SETQ |b|
- (COND
- (|a| (SETQ |str|
- (CONCAT |str|
- (STRING (SCHAR |$ln| |$n|))))
- (SETQ |$n| (+ |$n| 1)) (|shoeS|))
- (T (|shoeS|))))
- (CONCAT |str| |b|))))))))
+ (COND
+ ((NOT (< |$n| |$sz|))
+ (|SoftShoeError| (CONS |$linepos| |$n|) "quote added") "")
+ (T (SETQ |n| |$n|)
+ (SETQ |strsym| (OR (|charPosition| (|char| '|"|) |$ln| |$n|) |$sz|))
+ (SETQ |escsym| (OR (|charPosition| (|char| '_) |$ln| |$n|) |$sz|))
+ (SETQ |mn| (MIN |strsym| |escsym|))
+ (COND
+ ((EQUAL |mn| |$sz|) (SETQ |$n| |$sz|)
+ (|SoftShoeError| (CONS |$linepos| |$n|) "quote added")
+ (|subString| |$ln| |n|))
+ ((EQUAL |mn| |strsym|) (SETQ |$n| (+ |mn| 1))
+ (|subString| |$ln| |n| (- |mn| |n|)))
+ (T (SETQ |str| (|subString| |$ln| |n| (- |mn| |n|)))
+ (SETQ |$n| (+ |mn| 1)) (SETQ |a| (|shoeEsc|))
+ (SETQ |b|
+ (COND
+ (|a| (SETQ |str| (CONCAT |str| (STRING (SCHAR |$ln| |$n|))))
+ (SETQ |$n| (+ |$n| 1)) (|shoeS|))
+ (T (|shoeS|))))
+ (CONCAT |str| |b|))))))))
(DEFUN |shoeIdEnd| (|line| |n|)
(PROGN
- (LOOP
- (COND
- ((NOT (AND (< |n| (LENGTH |line|))
- (|shoeIdChar| (SCHAR |line| |n|))))
- (RETURN NIL))
- (T (SETQ |n| (+ |n| 1)))))
- |n|))
+ (LOOP
+ (COND
+ ((NOT (AND (< |n| (LENGTH |line|)) (|shoeIdChar| (SCHAR |line| |n|))))
+ (RETURN NIL))
+ (T (SETQ |n| (+ |n| 1)))))
+ |n|))
(DEFUN |shoeW| (|b|)
(PROG (|bb| |a| |str| |endid| |l| |n1|)
- (DECLARE (SPECIAL |$ln| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$ln|))
(RETURN
- (PROGN
- (SETQ |n1| |$n|)
- (SETQ |$n| (+ |$n| 1))
- (SETQ |l| |$sz|)
- (SETQ |endid| (|shoeIdEnd| |$ln| |$n|))
- (COND
- ((OR (EQUAL |endid| |l|)
- (NOT (CHAR= (SCHAR |$ln| |endid|) (|char| '_))))
- (SETQ |$n| |endid|)
- (LIST |b| (|subString| |$ln| |n1| (- |endid| |n1|))))
- (T (SETQ |str| (|subString| |$ln| |n1| (- |endid| |n1|)))
- (SETQ |$n| (+ |endid| 1)) (SETQ |a| (|shoeEsc|))
- (SETQ |bb| (COND (|a| (|shoeW| T)) (T (LIST |b| ""))))
- (LIST (OR (ELT |bb| 0) |b|) (CONCAT |str| (ELT |bb| 1)))))))))
+ (PROGN
+ (SETQ |n1| |$n|)
+ (SETQ |$n| (+ |$n| 1))
+ (SETQ |l| |$sz|)
+ (SETQ |endid| (|shoeIdEnd| |$ln| |$n|))
+ (COND
+ ((OR (EQUAL |endid| |l|)
+ (NOT (CHAR= (SCHAR |$ln| |endid|) (|char| '_))))
+ (SETQ |$n| |endid|)
+ (LIST |b| (|subString| |$ln| |n1| (- |endid| |n1|))))
+ (T (SETQ |str| (|subString| |$ln| |n1| (- |endid| |n1|)))
+ (SETQ |$n| (+ |endid| 1)) (SETQ |a| (|shoeEsc|))
+ (SETQ |bb| (COND (|a| (|shoeW| T)) (T (LIST |b| ""))))
+ (LIST (OR (ELT |bb| 0) |b|) (CONCAT |str| (ELT |bb| 1)))))))))
(DEFUN |shoeWord| (|esp|)
(PROG (|w| |aaa|)
(DECLARE (SPECIAL |$floatok|))
(RETURN
- (PROGN
- (SETQ |aaa| (|shoeW| NIL))
- (SETQ |w| (ELT |aaa| 1))
- (SETQ |$floatok| NIL)
- (COND
- ((OR |esp| (ELT |aaa| 0)) (|shoeLeafId| |w|))
- ((|shoeKeyWordP| |w|) (SETQ |$floatok| T)
- (|shoeLeafKey| |w|))
- (T (|shoeLeafId| |w|)))))))
+ (PROGN
+ (SETQ |aaa| (|shoeW| NIL))
+ (SETQ |w| (ELT |aaa| 1))
+ (SETQ |$floatok| NIL)
+ (COND ((OR |esp| (ELT |aaa| 0)) (|shoeLeafId| |w|))
+ ((|shoeKeyWordP| |w|) (SETQ |$floatok| T) (|shoeLeafKey| |w|))
+ (T (|shoeLeafId| |w|)))))))
(DEFUN |shoeInteger| () (|shoeInteger1| NIL))
(DEFUN |shoeInteger1| (|zro|)
(PROG (|bb| |a| |str| |l| |n|)
- (DECLARE (SPECIAL |$ln| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$ln|))
(RETURN
- (PROGN
- (SETQ |n| |$n|)
- (SETQ |l| |$sz|)
- (LOOP
- (COND
- ((NOT (AND (< |$n| |l|) (DIGIT-CHAR-P (SCHAR |$ln| |$n|))))
- (RETURN NIL))
- (T (SETQ |$n| (+ |$n| 1)))))
- (COND
- ((OR (EQUAL |$n| |l|)
- (NOT (CHAR= (SCHAR |$ln| |$n|) (|char| '_))))
- (COND
- ((AND (EQUAL |n| |$n|) |zro|) "0")
- (T (|subString| |$ln| |n| (- |$n| |n|)))))
- (T (SETQ |str| (|subString| |$ln| |n| (- |$n| |n|)))
- (SETQ |$n| (+ |$n| 1)) (SETQ |a| (|shoeEsc|))
- (SETQ |bb| (|shoeInteger1| |zro|)) (CONCAT |str| |bb|)))))))
+ (PROGN
+ (SETQ |n| |$n|)
+ (SETQ |l| |$sz|)
+ (LOOP
+ (COND
+ ((NOT (AND (< |$n| |l|) (DIGIT-CHAR-P (SCHAR |$ln| |$n|))))
+ (RETURN NIL))
+ (T (SETQ |$n| (+ |$n| 1)))))
+ (COND
+ ((OR (EQUAL |$n| |l|) (NOT (CHAR= (SCHAR |$ln| |$n|) (|char| '_))))
+ (COND ((AND (EQUAL |n| |$n|) |zro|) "0")
+ (T (|subString| |$ln| |n| (- |$n| |n|)))))
+ (T (SETQ |str| (|subString| |$ln| |n| (- |$n| |n|)))
+ (SETQ |$n| (+ |$n| 1)) (SETQ |a| (|shoeEsc|))
+ (SETQ |bb| (|shoeInteger1| |zro|)) (CONCAT |str| |bb|)))))))
(DEFUN |shoeIntValue| (|s|)
(PROG (|d| |ival| |ns|)
(RETURN
- (PROGN
- (SETQ |ns| (LENGTH |s|))
- (SETQ |ival| 0)
- (LET ((|bfVar#1| (- |ns| 1)) (|i| 0))
- (LOOP
- (COND
- ((> |i| |bfVar#1|) (RETURN NIL))
- (T (SETQ |d| (|shoeOrdToNum| (SCHAR |s| |i|)))
- (SETQ |ival| (+ (* 10 |ival|) |d|))))
- (SETQ |i| (+ |i| 1))))
- |ival|))))
+ (PROGN
+ (SETQ |ns| (LENGTH |s|))
+ (SETQ |ival| 0)
+ (LET ((|bfVar#1| (- |ns| 1)) (|i| 0))
+ (LOOP
+ (COND ((> |i| |bfVar#1|) (RETURN NIL))
+ (T (SETQ |d| (|shoeOrdToNum| (SCHAR |s| |i|)))
+ (SETQ |ival| (+ (* 10 |ival|) |d|))))
+ (SETQ |i| (+ |i| 1))))
+ |ival|))))
(DEFUN |shoeNumber| ()
(PROG (|w| |n| |a|)
- (DECLARE (SPECIAL |$ln| |$floatok| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$floatok| |$ln|))
(RETURN
- (PROGN
- (SETQ |a| (|shoeInteger|))
- (COND
- ((NOT (< |$n| |$sz|)) (|shoeLeafInteger| |a|))
- ((AND |$floatok| (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|)))
- (SETQ |n| |$n|) (SETQ |$n| (+ |$n| 1))
- (COND
- ((AND (< |$n| |$sz|)
- (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|)))
- (SETQ |$n| |n|) (|shoeLeafInteger| |a|))
- (T (SETQ |w| (|shoeInteger1| T)) (|shoeExponent| |a| |w|))))
- (T (|shoeLeafInteger| |a|)))))))
+ (PROGN
+ (SETQ |a| (|shoeInteger|))
+ (COND ((NOT (< |$n| |$sz|)) (|shoeLeafInteger| |a|))
+ ((AND |$floatok| (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|)))
+ (SETQ |n| |$n|) (SETQ |$n| (+ |$n| 1))
+ (COND
+ ((AND (< |$n| |$sz|) (CHAR= (SCHAR |$ln| |$n|) (|char| '|.|)))
+ (SETQ |$n| |n|) (|shoeLeafInteger| |a|))
+ (T (SETQ |w| (|shoeInteger1| T)) (|shoeExponent| |a| |w|))))
+ (T (|shoeLeafInteger| |a|)))))))
(DEFUN |shoeExponent| (|a| |w|)
(PROG (|c1| |e| |c| |n|)
- (DECLARE (SPECIAL |$ln| |$sz| |$n|))
+ (DECLARE (SPECIAL |$n| |$sz| |$ln|))
(RETURN
- (COND
- ((NOT (< |$n| |$sz|)) (|shoeLeafFloat| |a| |w| 0))
- (T (SETQ |n| |$n|) (SETQ |c| (SCHAR |$ln| |$n|))
- (COND
+ (COND ((NOT (< |$n| |$sz|)) (|shoeLeafFloat| |a| |w| 0))
+ (T (SETQ |n| |$n|) (SETQ |c| (SCHAR |$ln| |$n|))
+ (COND
((OR (CHAR= |c| (|char| 'E)) (CHAR= |c| (|char| '|e|)))
(SETQ |$n| (+ |$n| 1))
(COND
- ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
- (|shoeLeafFloat| |a| |w| 0))
- ((DIGIT-CHAR-P (SCHAR |$ln| |$n|))
- (SETQ |e| (|shoeInteger|))
- (SETQ |e| (|shoeIntValue| |e|))
- (|shoeLeafFloat| |a| |w| |e|))
- (T (SETQ |c1| (SCHAR |$ln| |$n|))
- (COND
- ((OR (CHAR= |c1| (|char| '+))
- (CHAR= |c1| (|char| '-)))
- (SETQ |$n| (+ |$n| 1))
- (COND
- ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
- (|shoeLeafFloat| |a| |w| 0))
- ((DIGIT-CHAR-P (SCHAR |$ln| |$n|))
- (SETQ |e| (|shoeInteger|))
- (SETQ |e| (|shoeIntValue| |e|))
- (|shoeLeafFloat| |a| |w|
- (COND
- ((CHAR= |c1| (|char| '-)) (- |e|))
- (T |e|))))
- (T (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0))))))))
+ ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
+ (|shoeLeafFloat| |a| |w| 0))
+ ((DIGIT-CHAR-P (SCHAR |$ln| |$n|)) (SETQ |e| (|shoeInteger|))
+ (SETQ |e| (|shoeIntValue| |e|)) (|shoeLeafFloat| |a| |w| |e|))
+ (T (SETQ |c1| (SCHAR |$ln| |$n|))
+ (COND
+ ((OR (CHAR= |c1| (|char| '+)) (CHAR= |c1| (|char| '-)))
+ (SETQ |$n| (+ |$n| 1))
+ (COND
+ ((NOT (< |$n| |$sz|)) (SETQ |$n| |n|)
+ (|shoeLeafFloat| |a| |w| 0))
+ ((DIGIT-CHAR-P (SCHAR |$ln| |$n|))
+ (SETQ |e| (|shoeInteger|)) (SETQ |e| (|shoeIntValue| |e|))
+ (|shoeLeafFloat| |a| |w|
+ (COND ((CHAR= |c1| (|char| '-)) (- |e|))
+ (T |e|))))
+ (T (SETQ |$n| |n|) (|shoeLeafFloat| |a| |w| 0))))))))
(T (|shoeLeafFloat| |a| |w| 0))))))))
(DEFUN |shoeError| ()
(PROG (|n|)
- (DECLARE (SPECIAL |$ln| |$linepos| |$n|))
+ (DECLARE (SPECIAL |$n| |$linepos| |$ln|))
(RETURN
- (PROGN
- (SETQ |n| |$n|)
- (SETQ |$n| (+ |$n| 1))
- (|SoftShoeError| (CONS |$linepos| |n|)
- (CONCAT "The character whose number is "
- (WRITE-TO-STRING (CHAR-CODE (SCHAR |$ln| |n|)))
- " is not a Boot character"))
- (|shoeLeafError| (SCHAR |$ln| |n|))))))
+ (PROGN
+ (SETQ |n| |$n|)
+ (SETQ |$n| (+ |$n| 1))
+ (|SoftShoeError| (CONS |$linepos| |n|)
+ (CONCAT "The character whose number is "
+ (WRITE-TO-STRING (CHAR-CODE (SCHAR |$ln| |n|)))
+ " is not a Boot character"))
+ (|shoeLeafError| (SCHAR |$ln| |n|))))))
(DEFUN |shoeOrdToNum| (|x|) (DIGIT-CHAR-P |x|))
@@ -521,39 +473,37 @@
(DEFUN |shoeKeyWordP| (|st|) (|tableValue| |shoeKeyTable| |st|))
-(DEFUN |shoeMatch| (|l| |i|)
- (|shoeSubStringMatch| |l| |shoeDict| |i|))
+(DEFUN |shoeMatch| (|l| |i|) (|shoeSubStringMatch| |l| |shoeDict| |i|))
(DEFUN |shoeSubStringMatch| (|l| |d| |i|)
(PROG (|eql| |ls| |s| |s1| |done| |ll| |u| |h|)
(RETURN
- (PROGN
- (SETQ |h| (CHAR-CODE (SCHAR |l| |i|)))
- (SETQ |u| (ELT |d| |h|))
- (SETQ |ll| (LENGTH |l|))
- (SETQ |done| NIL)
- (SETQ |s1| "")
- (LET ((|bfVar#1| (- (LENGTH |u|) 1)) (|j| 0))
- (LOOP
- (COND
- ((OR (> |j| |bfVar#1|) |done|) (RETURN NIL))
- (T (SETQ |s| (ELT |u| |j|)) (SETQ |ls| (LENGTH |s|))
- (SETQ |done|
- (COND
- ((< |ll| (+ |ls| |i|)) NIL)
- (T (SETQ |eql| T)
- (LET ((|bfVar#2| (- |ls| 1)) (|k| 1))
- (LOOP
- (COND
- ((OR (> |k| |bfVar#2|) (NOT |eql|))
- (RETURN NIL))
- (T (SETQ |eql|
- (CHAR= (SCHAR |s| |k|)
- (SCHAR |l| (+ |k| |i|))))))
- (SETQ |k| (+ |k| 1))))
- (COND (|eql| (SETQ |s1| |s|) T) (T NIL)))))))
- (SETQ |j| (+ |j| 1))))
- |s1|))))
+ (PROGN
+ (SETQ |h| (CHAR-CODE (SCHAR |l| |i|)))
+ (SETQ |u| (ELT |d| |h|))
+ (SETQ |ll| (LENGTH |l|))
+ (SETQ |done| NIL)
+ (SETQ |s1| "")
+ (LET ((|bfVar#1| (- (LENGTH |u|) 1)) (|j| 0))
+ (LOOP
+ (COND ((OR (> |j| |bfVar#1|) |done|) (RETURN NIL))
+ (T (SETQ |s| (ELT |u| |j|)) (SETQ |ls| (LENGTH |s|))
+ (SETQ |done|
+ (COND ((< |ll| (+ |ls| |i|)) NIL)
+ (T (SETQ |eql| T)
+ (LET ((|bfVar#2| (- |ls| 1)) (|k| 1))
+ (LOOP
+ (COND
+ ((OR (> |k| |bfVar#2|) (NOT |eql|))
+ (RETURN NIL))
+ (T
+ (SETQ |eql|
+ (CHAR= (SCHAR |s| |k|)
+ (SCHAR |l| (+ |k| |i|))))))
+ (SETQ |k| (+ |k| 1))))
+ (COND (|eql| (SETQ |s1| |s|) T) (T NIL)))))))
+ (SETQ |j| (+ |j| 1))))
+ |s1|))))
(DEFUN |shoePunctuation| (|c|) (EQL (ELT |shoePun| |c|) 1))
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index c8c4afc3..de9d71e3 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -19,290 +19,247 @@
(DEFUN |shoeIdChar| (|x|)
(OR (ALPHANUMERICP |x|)
(|charMember?| |x|
- (LIST (|char| '|'|) (|char| '?) (|char| '%) (|char| '!)
- (|char| '&)))))
+ (LIST (|char| '|'|) (|char| '?) (|char| '%) (|char| '!)
+ (|char| '&)))))
(DEFUN |subString| (|s| |f| &OPTIONAL (|n| NIL))
- (COND
- ((NULL |n|) (SUBSEQ |s| |f|))
- (T (SUBSEQ |s| |f| (+ |f| |n|)))))
+ (COND ((NULL |n|) (SUBSEQ |s| |f|)) (T (SUBSEQ |s| |f| (+ |f| |n|)))))
(DEFCONSTANT |shoeKeyWords|
- (LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE)
- (LIST "catch" 'CATCH) (LIST "cross" 'CROSS) (LIST "do" 'DO)
- (LIST "else" 'ELSE) (LIST "finally" 'FINALLY)
- (LIST "for" 'FOR) (LIST "forall" 'FORALL) (LIST "has" 'HAS)
- (LIST "if" 'IF) (LIST "import" 'IMPORT) (LIST "in" 'IN)
- (LIST "is" 'IS) (LIST "isnt" 'ISNT) (LIST "leave" 'LEAVE)
- (LIST "macro" 'MACRO) (LIST "module" 'MODULE)
- (LIST "namespace" 'NAMESPACE) (LIST "of" 'OF) (LIST "or" 'OR)
- (LIST "rem" 'REM) (LIST "repeat" 'REPEAT)
- (LIST "return" 'RETURN) (LIST "quo" 'QUO)
- (LIST "structure" 'STRUCTURE) (LIST "then" 'THEN)
- (LIST "throw" 'THROW) (LIST "try" 'TRY) (LIST "until" 'UNTIL)
- (LIST "where" 'WHERE) (LIST "while" 'WHILE) (LIST "." 'DOT)
- (LIST ":" 'COLON) (LIST "::" 'COLON-COLON) (LIST "," 'COMMA)
- (LIST ";" 'SEMICOLON) (LIST "*" 'TIMES) (LIST "**" 'POWER)
- (LIST "/" 'SLASH) (LIST "+" 'PLUS) (LIST "-" 'MINUS)
- (LIST "<" 'LT) (LIST ">" 'GT) (LIST "<=" 'LE) (LIST ">=" 'GE)
- (LIST "=" 'SHOEEQ) (LIST "~=" 'SHOENE) (LIST ".." 'SEG)
- (LIST "#" 'LENGTH) (LIST "=>" 'EXIT) (LIST "->" 'ARROW)
- (LIST ":=" 'BEC) (LIST "+->" 'GIVES) (LIST "==" 'DEF)
- (LIST "<=>" 'TDEF) (LIST "(" 'OPAREN) (LIST ")" 'CPAREN)
- (LIST "[" 'OBRACK) (LIST "]" 'CBRACK) (LIST "'" 'QUOTE)
- (LIST "|" 'BAR)))
+ (LIST (LIST "and" 'AND) (LIST "by" 'BY) (LIST "case" 'CASE)
+ (LIST "catch" 'CATCH) (LIST "cross" 'CROSS) (LIST "do" 'DO)
+ (LIST "else" 'ELSE) (LIST "finally" 'FINALLY) (LIST "for" 'FOR)
+ (LIST "forall" 'FORALL) (LIST "has" 'HAS) (LIST "if" 'IF)
+ (LIST "import" 'IMPORT) (LIST "in" 'IN) (LIST "is" 'IS)
+ (LIST "isnt" 'ISNT) (LIST "leave" 'LEAVE) (LIST "macro" 'MACRO)
+ (LIST "module" 'MODULE) (LIST "namespace" 'NAMESPACE) (LIST "of" 'OF)
+ (LIST "or" 'OR) (LIST "rem" 'REM) (LIST "repeat" 'REPEAT)
+ (LIST "return" 'RETURN) (LIST "quo" 'QUO) (LIST "structure" 'STRUCTURE)
+ (LIST "then" 'THEN) (LIST "throw" 'THROW) (LIST "try" 'TRY)
+ (LIST "until" 'UNTIL) (LIST "where" 'WHERE) (LIST "while" 'WHILE)
+ (LIST "." 'DOT) (LIST ":" 'COLON) (LIST "::" 'COLON-COLON)
+ (LIST "," 'COMMA) (LIST ";" 'SEMICOLON) (LIST "*" 'TIMES)
+ (LIST "**" 'POWER) (LIST "/" 'SLASH) (LIST "+" 'PLUS) (LIST "-" 'MINUS)
+ (LIST "<" 'LT) (LIST ">" 'GT) (LIST "<=" 'LE) (LIST ">=" 'GE)
+ (LIST "=" 'SHOEEQ) (LIST "~=" 'SHOENE) (LIST ".." 'SEG)
+ (LIST "#" 'LENGTH) (LIST "=>" 'EXIT) (LIST "->" 'ARROW)
+ (LIST ":=" 'BEC) (LIST "+->" 'GIVES) (LIST "==" 'DEF)
+ (LIST "<=>" 'TDEF) (LIST "(" 'OPAREN) (LIST ")" 'CPAREN)
+ (LIST "[" 'OBRACK) (LIST "]" 'CBRACK) (LIST "'" 'QUOTE)
+ (LIST "|" 'BAR)))
(DEFUN |shoeKeyTableCons| ()
(PROG (|KeyTable|)
(RETURN
- (PROGN
- (SETQ |KeyTable| (|makeTable| #'EQUAL))
- (LET ((|bfVar#1| |shoeKeyWords|) (|st| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |st| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETF (|tableValue| |KeyTable| (CAR |st|))
- (CADR |st|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- |KeyTable|))))
+ (PROGN
+ (SETQ |KeyTable| (|makeTable| #'EQUAL))
+ (LET ((|bfVar#1| |shoeKeyWords|) (|st| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |st| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETF (|tableValue| |KeyTable| (CAR |st|)) (CADR |st|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ |KeyTable|))))
(DEFPARAMETER |shoeKeyTable| (|shoeKeyTableCons|))
(DEFUN |shoeInsert| (|s| |d|)
(PROG (|v| |k| |n| |u| |h| |l|)
(RETURN
- (PROGN
- (SETQ |l| (LENGTH |s|))
- (SETQ |h| (CHAR-CODE (SCHAR |s| 0)))
- (SETQ |u| (ELT |d| |h|))
- (SETQ |n| (LENGTH |u|))
- (SETQ |k| 0)
+ (PROGN
+ (SETQ |l| (LENGTH |s|))
+ (SETQ |h| (CHAR-CODE (SCHAR |s| 0)))
+ (SETQ |u| (ELT |d| |h|))
+ (SETQ |n| (LENGTH |u|))
+ (SETQ |k| 0)
+ (LOOP
+ (COND ((< (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL))
+ (T (SETQ |k| (+ |k| 1)))))
+ (SETQ |v| (MAKE-ARRAY (+ |n| 1)))
+ (LET ((|bfVar#1| (- |k| 1)) (|i| 0))
+ (LOOP
+ (COND ((> |i| |bfVar#1|) (RETURN NIL))
+ (T (SETF (ELT |v| |i|) (ELT |u| |i|))))
+ (SETQ |i| (+ |i| 1))))
+ (SETF (ELT |v| |k|) |s|)
+ (LET ((|bfVar#2| (- |n| 1)) (|i| |k|))
(LOOP
- (COND
- ((< (LENGTH (ELT |u| |k|)) |l|) (RETURN NIL))
- (T (SETQ |k| (+ |k| 1)))))
- (SETQ |v| (MAKE-ARRAY (+ |n| 1)))
- (LET ((|bfVar#1| (- |k| 1)) (|i| 0))
- (LOOP
- (COND
- ((> |i| |bfVar#1|) (RETURN NIL))
- (T (SETF (ELT |v| |i|) (ELT |u| |i|))))
- (SETQ |i| (+ |i| 1))))
- (SETF (ELT |v| |k|) |s|)
- (LET ((|bfVar#2| (- |n| 1)) (|i| |k|))
- (LOOP
- (COND
- ((> |i| |bfVar#2|) (RETURN NIL))
- (T (SETF (ELT |v| (+ |i| 1)) (ELT |u| |i|))))
- (SETQ |i| (+ |i| 1))))
- (SETF (ELT |d| |h|) |v|)
- |s|))))
+ (COND ((> |i| |bfVar#2|) (RETURN NIL))
+ (T (SETF (ELT |v| (+ |i| 1)) (ELT |u| |i|))))
+ (SETQ |i| (+ |i| 1))))
+ (SETF (ELT |d| |h|) |v|)
+ |s|))))
(DEFUN |shoeDictCons| ()
(PROG (|d| |b| |a| |l|)
(RETURN
- (PROGN
- (SETQ |l| (HKEYS |shoeKeyTable|))
- (SETQ |d|
+ (PROGN
+ (SETQ |l| (HKEYS |shoeKeyTable|))
+ (SETQ |d|
(PROGN
- (SETQ |a| (MAKE-ARRAY 256))
- (SETQ |b| (MAKE-ARRAY 1))
- (SETF (ELT |b| 0) (MAKE-STRING 0))
- (LET ((|i| 0))
- (LOOP
- (COND
- ((> |i| 255) (RETURN NIL))
- (T (SETF (ELT |a| |i|) |b|)))
- (SETQ |i| (+ |i| 1))))
- |a|))
- (LET ((|bfVar#1| |l|) (|s| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |s| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (|shoeInsert| |s| |d|)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- |d|))))
+ (SETQ |a| (MAKE-ARRAY 256))
+ (SETQ |b| (MAKE-ARRAY 1))
+ (SETF (ELT |b| 0) (MAKE-STRING 0))
+ (LET ((|i| 0))
+ (LOOP
+ (COND ((> |i| 255) (RETURN NIL))
+ (T (SETF (ELT |a| |i|) |b|)))
+ (SETQ |i| (+ |i| 1))))
+ |a|))
+ (LET ((|bfVar#1| |l|) (|s| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |s| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (|shoeInsert| |s| |d|)))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ |d|))))
(DEFPARAMETER |shoeDict| (|shoeDictCons|))
(DEFUN |shoePunCons| ()
(PROG (|a| |listing|)
(RETURN
- (PROGN
- (SETQ |listing| (HKEYS |shoeKeyTable|))
- (SETQ |a| (|makeBitVector| 256))
- (LET ((|i| 0))
- (LOOP
- (COND
- ((> |i| 255) (RETURN NIL))
- (T (SETF (SBIT |a| |i|) 0)))
- (SETQ |i| (+ |i| 1))))
- (LET ((|bfVar#1| |listing|) (|k| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |k| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- ((|shoeStartsId| (ELT |k| 0)) NIL)
- (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- |a|))))
+ (PROGN
+ (SETQ |listing| (HKEYS |shoeKeyTable|))
+ (SETQ |a| (|makeBitVector| 256))
+ (LET ((|i| 0))
+ (LOOP (COND ((> |i| 255) (RETURN NIL)) (T (SETF (SBIT |a| |i|) 0)))
+ (SETQ |i| (+ |i| 1))))
+ (LET ((|bfVar#1| |listing|) (|k| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |k| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ ((|shoeStartsId| (ELT |k| 0)) NIL)
+ (T (SETF (SBIT |a| (CHAR-CODE (SCHAR |k| 0))) 1)))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ |a|))))
(DEFPARAMETER |shoePun| (|shoePunCons|))
(LET ((|bfVar#1| (LIST 'NOT 'LENGTH)) (|i| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETF (GET |i| 'SHOEPRE) T)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETF (GET |i| 'SHOEPRE) T)))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
(LET ((|bfVar#1|
- (LIST (LIST 'SHOEEQ '=) (LIST 'TIMES '*) (LIST 'REM '|rem|)
- (LIST 'QUO '|quo|) (LIST 'PLUS '+) (LIST 'IS '|is|)
- (LIST 'ISNT '|isnt|) (LIST 'AND '|and|)
- (LIST 'OR '|or|) (LIST 'SLASH '/) (LIST 'POWER '**)
- (LIST 'MINUS '-) (LIST 'LT '<) (LIST 'GT '>)
- (LIST 'LE '<=) (LIST 'GE '>=) (LIST 'SHOENE '~=)))
+ (LIST (LIST 'SHOEEQ '=) (LIST 'TIMES '*) (LIST 'REM '|rem|)
+ (LIST 'QUO '|quo|) (LIST 'PLUS '+) (LIST 'IS '|is|)
+ (LIST 'ISNT '|isnt|) (LIST 'AND '|and|) (LIST 'OR '|or|)
+ (LIST 'SLASH '/) (LIST 'POWER '**) (LIST 'MINUS '-) (LIST 'LT '<)
+ (LIST 'GT '>) (LIST 'LE '<=) (LIST 'GE '>=) (LIST 'SHOENE '~=)))
(|i| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETF (GET (CAR |i|) 'SHOEINF) (CADR |i|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETF (GET (CAR |i|) 'SHOEINF) (CADR |i|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
(LET ((|bfVar#1|
- (LIST (LIST '+ 0) (LIST '|gcd| 0) (LIST '|lcm| 1)
- (LIST 'STRCONC "") (LIST '|strconc| "")
- (LIST 'CONCAT "") (LIST 'MAX (- 999999))
- (LIST 'MIN 999999) (LIST '* 1) (LIST '|times| 1)
- (LIST 'CONS NIL) (LIST '|append| NIL)
- (LIST '|append!| NIL) (LIST 'UNION NIL)
- (LIST 'UNIONQ NIL) (LIST '|union| NIL) (LIST '|and| T)
- (LIST '|or| NIL) (LIST 'AND T) (LIST 'OR NIL)))
+ (LIST (LIST '+ 0) (LIST '|gcd| 0) (LIST '|lcm| 1) (LIST 'STRCONC "")
+ (LIST '|strconc| "") (LIST 'CONCAT "") (LIST 'MAX (- 999999))
+ (LIST 'MIN 999999) (LIST '* 1) (LIST '|times| 1) (LIST 'CONS NIL)
+ (LIST '|append| NIL) (LIST '|append!| NIL) (LIST 'UNION NIL)
+ (LIST 'UNIONQ NIL) (LIST '|union| NIL) (LIST '|and| T)
+ (LIST '|or| NIL) (LIST 'AND T) (LIST 'OR NIL)))
(|i| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETF (GET (CAR |i|) 'SHOETHETA) (CDR |i|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETF (GET (CAR |i|) 'SHOETHETA) (CDR |i|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
(LET ((|bfVar#1|
- (LIST (LIST '|abs| 'ABS) (LIST '|abstractChar| 'CODE-CHAR)
- (LIST '|alphabetic?| 'ALPHA-CHAR-P)
- (LIST '|alphanumeric?| 'ALPHANUMERICP)
- (LIST '|and| 'AND) (LIST '|apply| 'APPLY)
- (LIST '|array?| 'ARRAYP) (LIST '|arrayRef| 'AREF)
- (LIST '|atom| 'ATOM) (LIST '|bitmask| 'SBIT)
- (LIST '|canonicalFilename| 'PROBE-FILE)
- (LIST '|charByName| 'NAME-CHAR)
- (LIST '|charDowncase| 'CHAR-DOWNCASE)
- (LIST '|charEq?| 'CHAR=)
- (LIST '|charUpcase| 'CHAR-UPCASE)
- (LIST '|charString| 'STRING)
- (LIST '|char?| 'CHARACTERP)
- (LIST '|codePoint| 'CHAR-CODE) (LIST '|cons?| 'CONSP)
- (LIST '|copy| 'COPY) (LIST '|copyString| 'COPY-SEQ)
- (LIST '|copyTree| 'COPY-TREE)
- (LIST '|copyVector| 'COPY-SEQ) (LIST '|croak| 'CROAK)
- (LIST '|digit?| 'DIGIT-CHAR-P) (LIST '|drop| 'DROP)
- (LIST '|exit| 'EXIT) (LIST '|false| 'NIL)
- (LIST '|first| 'CAR) (LIST '|float?| 'FLOATP)
- (LIST '|flushOutput| 'FORCE-OUTPUT)
- (LIST '|fourth| 'CADDDR) (LIST '|function| 'FUNCTION)
- (LIST '|function?| 'FUNCTIONP) (LIST '|gensym| 'GENSYM)
- (LIST '|genvar| 'GENVAR) (LIST '|integer?| 'INTEGERP)
- (LIST 'LAST '|last|) (LIST '|list| 'LIST)
- (LIST '|listEq?| 'EQUAL)
- (LIST '|lowerCase?| 'LOWER-CASE-P)
- (LIST '|makeSymbol| 'INTERN)
- (LIST '|maxIndex| 'MAXINDEX) (LIST '|mkpf| 'MKPF)
- (LIST '|newString| 'MAKE-STRING)
- (LIST '|newVector| 'MAKE-ARRAY) (LIST '|nil| NIL)
- (LIST '|not| 'NOT) (LIST '|null| 'NULL)
- (LIST '|odd?| 'ODDP) (LIST '|or| 'OR)
- (LIST '|otherwise| 'T) (LIST '|property| 'GET)
- (LIST '|readInteger| 'PARSE-INTEGER)
- (LIST '|readLispFromString| 'READ-FROM-STRING)
- (LIST '|readOnly?| 'CONSTANTP)
- (LIST '|removeDuplicates| 'REMDUP) (LIST '|rest| 'CDR)
- (LIST '|sameObject?| 'EQ) (LIST '|scalarEq?| 'EQL)
- (LIST '|scalarEqual?| 'EQL) (LIST '|second| 'CADR)
- (LIST '|setIntersection| 'INTERSECTION)
- (LIST '|setPart| 'SETELT) (LIST '|setUnion| 'UNION)
- (LIST '|strconc| 'CONCAT) (LIST '|stringChar| 'SCHAR)
- (LIST '|stringDowncase| 'STRING-DOWNCASE)
- (LIST '|string?| 'STRINGP) (LIST '|stringEq?| 'STRING=)
- (LIST '|stringUpcase| 'STRING-UPCASE)
- (LIST '|subSequence| 'SUBSEQ)
- (LIST '|symbolScope| 'SYMBOL-PACKAGE)
- (LIST '|symbolEq?| 'EQ)
- (LIST '|symbolFunction| 'SYMBOL-FUNCTION)
- (LIST '|symbolName| 'SYMBOL-NAME)
- (LIST '|symbolValue| 'SYMBOL-VALUE)
- (LIST '|symbol?| 'SYMBOLP) (LIST '|take| 'TAKE)
- (LIST '|third| 'CADDR)
- (LIST '|toString| 'WRITE-TO-STRING) (LIST '|true| 'T)
- (LIST '|upperCase?| 'UPPER-CASE-P)
- (LIST '|valueEq?| 'EQUAL)
- (LIST '|vector?| 'SIMPLE-VECTOR-P)
- (LIST '|vectorRef| 'SVREF)
- (LIST '|writeByte| 'WRITE-BYTE)
- (LIST '|writeChar| 'WRITE-CHAR)
- (LIST '|writeInteger| 'PRINC)
- (LIST '|writeLine| 'WRITE-LINE)
- (LIST '|writeNewline| 'TERPRI)
- (LIST '|writeString| 'WRITE-STRING) (LIST 'PLUS '+)
- (LIST 'MINUS '-) (LIST 'TIMES '*) (LIST 'POWER 'EXPT)
- (LIST 'REM 'REM) (LIST 'QUO 'TRUNCATE) (LIST 'SLASH '/)
- (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=)
- (LIST 'GE '>=) (LIST 'SHOEEQ 'EQUAL) (LIST 'SHOENE '/=)
- (LIST 'T 'T$)))
+ (LIST (LIST '|abs| 'ABS) (LIST '|abstractChar| 'CODE-CHAR)
+ (LIST '|alphabetic?| 'ALPHA-CHAR-P)
+ (LIST '|alphanumeric?| 'ALPHANUMERICP) (LIST '|and| 'AND)
+ (LIST '|apply| 'APPLY) (LIST '|array?| 'ARRAYP)
+ (LIST '|arrayRef| 'AREF) (LIST '|atom| 'ATOM)
+ (LIST '|bitmask| 'SBIT) (LIST '|canonicalFilename| 'PROBE-FILE)
+ (LIST '|charByName| 'NAME-CHAR)
+ (LIST '|charDowncase| 'CHAR-DOWNCASE) (LIST '|charEq?| 'CHAR=)
+ (LIST '|charUpcase| 'CHAR-UPCASE) (LIST '|charString| 'STRING)
+ (LIST '|char?| 'CHARACTERP) (LIST '|codePoint| 'CHAR-CODE)
+ (LIST '|cons?| 'CONSP) (LIST '|copy| 'COPY)
+ (LIST '|copyString| 'COPY-SEQ) (LIST '|copyTree| 'COPY-TREE)
+ (LIST '|copyVector| 'COPY-SEQ) (LIST '|croak| 'CROAK)
+ (LIST '|digit?| 'DIGIT-CHAR-P) (LIST '|drop| 'DROP)
+ (LIST '|exit| 'EXIT) (LIST '|false| 'NIL) (LIST '|first| 'CAR)
+ (LIST '|float?| 'FLOATP) (LIST '|flushOutput| 'FORCE-OUTPUT)
+ (LIST '|fourth| 'CADDDR) (LIST '|function| 'FUNCTION)
+ (LIST '|function?| 'FUNCTIONP) (LIST '|gensym| 'GENSYM)
+ (LIST '|genvar| 'GENVAR) (LIST '|integer?| 'INTEGERP)
+ (LIST 'LAST '|last|) (LIST '|list| 'LIST) (LIST '|listEq?| 'EQUAL)
+ (LIST '|lowerCase?| 'LOWER-CASE-P) (LIST '|makeSymbol| 'INTERN)
+ (LIST '|maxIndex| 'MAXINDEX) (LIST '|mkpf| 'MKPF)
+ (LIST '|newString| 'MAKE-STRING) (LIST '|newVector| 'MAKE-ARRAY)
+ (LIST '|nil| NIL) (LIST '|not| 'NOT) (LIST '|null| 'NULL)
+ (LIST '|odd?| 'ODDP) (LIST '|or| 'OR) (LIST '|otherwise| 'T)
+ (LIST '|property| 'GET) (LIST '|readInteger| 'PARSE-INTEGER)
+ (LIST '|readLispFromString| 'READ-FROM-STRING)
+ (LIST '|readOnly?| 'CONSTANTP) (LIST '|removeDuplicates| 'REMDUP)
+ (LIST '|rest| 'CDR) (LIST '|sameObject?| 'EQ)
+ (LIST '|scalarEq?| 'EQL) (LIST '|scalarEqual?| 'EQL)
+ (LIST '|second| 'CADR) (LIST '|setIntersection| 'INTERSECTION)
+ (LIST '|setPart| 'SETELT) (LIST '|setUnion| 'UNION)
+ (LIST '|strconc| 'CONCAT) (LIST '|stringChar| 'SCHAR)
+ (LIST '|stringDowncase| 'STRING-DOWNCASE)
+ (LIST '|string?| 'STRINGP) (LIST '|stringEq?| 'STRING=)
+ (LIST '|stringUpcase| 'STRING-UPCASE)
+ (LIST '|subSequence| 'SUBSEQ)
+ (LIST '|symbolScope| 'SYMBOL-PACKAGE) (LIST '|symbolEq?| 'EQ)
+ (LIST '|symbolFunction| 'SYMBOL-FUNCTION)
+ (LIST '|symbolName| 'SYMBOL-NAME)
+ (LIST '|symbolValue| 'SYMBOL-VALUE) (LIST '|symbol?| 'SYMBOLP)
+ (LIST '|take| 'TAKE) (LIST '|third| 'CADDR)
+ (LIST '|toString| 'WRITE-TO-STRING) (LIST '|true| 'T)
+ (LIST '|upperCase?| 'UPPER-CASE-P) (LIST '|valueEq?| 'EQUAL)
+ (LIST '|vector?| 'SIMPLE-VECTOR-P) (LIST '|vectorRef| 'SVREF)
+ (LIST '|writeByte| 'WRITE-BYTE) (LIST '|writeChar| 'WRITE-CHAR)
+ (LIST '|writeInteger| 'PRINC) (LIST '|writeLine| 'WRITE-LINE)
+ (LIST '|writeNewline| 'TERPRI) (LIST '|writeString| 'WRITE-STRING)
+ (LIST 'PLUS '+) (LIST 'MINUS '-) (LIST 'TIMES '*)
+ (LIST 'POWER 'EXPT) (LIST 'REM 'REM) (LIST 'QUO 'TRUNCATE)
+ (LIST 'SLASH '/) (LIST 'LT '<) (LIST 'GT '>) (LIST 'LE '<=)
+ (LIST 'GE '>=) (LIST 'SHOEEQ 'EQUAL) (LIST 'SHOENE '/=)
+ (LIST 'T 'T$)))
(|i| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETF (GET (CAR |i|) 'SHOERENAME) (CDR |i|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETF (GET (CAR |i|) 'SHOERENAME) (CDR |i|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
(LET ((|bfVar#1|
- (LIST (LIST '|setName| 0) (LIST '|setLabel| 1)
- (LIST '|setLevel| 2) (LIST '|setType| 3)
- (LIST '|setVar| 4) (LIST '|setLeaf| 5)
- (LIST '|setDef| 6) (LIST '|aGeneral| 4)
- (LIST '|aMode| 1) (LIST '|aModeSet| 3)
- (LIST '|aTree| 0) (LIST '|aValue| 2)
- (LIST '|args| 'CDR) (LIST '|attributes| 'CADDR)
- (LIST '|cacheCount| 'CADDDDR) (LIST '|cacheName| 'CADR)
- (LIST '|cacheReset| 'CADDDR) (LIST '|cacheType| 'CADDR)
- (LIST '|env| 'CADDR) (LIST '|expr| 'CAR)
- (LIST 'CAR 'CAR) (LIST '|mmCondition| 'CAADR)
- (LIST '|mmDC| 'CAAR) (LIST '|mmImplementation| 'CADADR)
- (LIST '|mmSignature| 'CDAR) (LIST '|mmTarget| 'CADAR)
- (LIST '|mmSource| 'CDDAR) (LIST '|mode| 'CADR)
- (LIST '|op| 'CAR) (LIST '|opcode| 'CADR)
- (LIST '|opSig| 'CADR) (LIST 'CDR 'CDR)
- (LIST '|sig| 'CDDR) (LIST '|source| 'CDR)
- (LIST '|streamCode| 'CADDDR) (LIST '|streamDef| 'CADDR)
- (LIST '|streamName| 'CADR) (LIST '|target| 'CAR)))
+ (LIST (LIST '|setName| 0) (LIST '|setLabel| 1) (LIST '|setLevel| 2)
+ (LIST '|setType| 3) (LIST '|setVar| 4) (LIST '|setLeaf| 5)
+ (LIST '|setDef| 6) (LIST '|aGeneral| 4) (LIST '|aMode| 1)
+ (LIST '|aModeSet| 3) (LIST '|aTree| 0) (LIST '|aValue| 2)
+ (LIST '|args| 'CDR) (LIST '|attributes| 'CADDR)
+ (LIST '|cacheCount| 'CADDDDR) (LIST '|cacheName| 'CADR)
+ (LIST '|cacheReset| 'CADDDR) (LIST '|cacheType| 'CADDR)
+ (LIST '|env| 'CADDR) (LIST '|expr| 'CAR) (LIST 'CAR 'CAR)
+ (LIST '|mmCondition| 'CAADR) (LIST '|mmDC| 'CAAR)
+ (LIST '|mmImplementation| 'CADADR) (LIST '|mmSignature| 'CDAR)
+ (LIST '|mmTarget| 'CADAR) (LIST '|mmSource| 'CDDAR)
+ (LIST '|mode| 'CADR) (LIST '|op| 'CAR) (LIST '|opcode| 'CADR)
+ (LIST '|opSig| 'CADR) (LIST 'CDR 'CDR) (LIST '|sig| 'CDDR)
+ (LIST '|source| 'CDR) (LIST '|streamCode| 'CADDDR)
+ (LIST '|streamDef| 'CADDR) (LIST '|streamName| 'CADR)
+ (LIST '|target| 'CAR)))
(|i| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETF (GET (CAR |i|) 'SHOESELFUNCTION) (CADR |i|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETF (GET (CAR |i|) 'SHOESELFUNCTION) (CADR |i|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp
index 79d072bf..12dda96a 100644
--- a/src/boot/strap/translator.clisp
+++ b/src/boot/strap/translator.clisp
@@ -14,8 +14,9 @@
(PROVIDE "translator")
(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
- (EXPORT '(|evalBootFile| |loadNativeModule| |loadSystemRuntimeCore|
- |string2BootTree| |genImportDeclaration|)))
+ (EXPORT
+ '(|evalBootFile| |loadNativeModule| |loadSystemRuntimeCore|
+ |string2BootTree| |genImportDeclaration|)))
(DEFPARAMETER |$currentModuleName| NIL)
@@ -23,102 +24,82 @@
(DEFUN |genModuleFinalization| (|stream|)
(PROG (|init|)
- (DECLARE (SPECIAL |$currentModuleName| |$foreignsDefsForCLisp|))
+ (DECLARE (SPECIAL |$foreignsDefsForCLisp| |$currentModuleName|))
(RETURN
- (COND
- ((|%hasFeature| :CLISP)
- (COND
- ((NULL |$foreignsDefsForCLisp|) NIL)
- ((NULL |$currentModuleName|)
- (|coreError| "current module has no name"))
- (T (SETQ |init|
- (CONS 'DEFUN
- (CONS (INTERN (CONCAT |$currentModuleName|
- "InitCLispFFI"))
- (CONS NIL
- (CONS
- (LIST 'MAPC
- (LIST 'FUNCTION 'FMAKUNBOUND)
- (|quote|
- (LET
- ((|bfVar#2| NIL)
- (|bfVar#3| NIL)
- (|bfVar#1|
- |$foreignsDefsForCLisp|)
- (|d| NIL))
- (LOOP
- (COND
- ((OR
- (NOT
- (CONSP |bfVar#1|))
- (PROGN
- (SETQ |d|
- (CAR |bfVar#1|))
- NIL))
+ (COND
+ ((|%hasFeature| :CLISP)
+ (COND ((NULL |$foreignsDefsForCLisp|) NIL)
+ ((NULL |$currentModuleName|)
+ (|coreError| "current module has no name"))
+ (T
+ (SETQ |init|
+ (CONS 'DEFUN
+ (CONS
+ (INTERN
+ (CONCAT |$currentModuleName| "InitCLispFFI"))
+ (CONS NIL
+ (CONS
+ (LIST 'MAPC (LIST 'FUNCTION 'FMAKUNBOUND)
+ (|quote|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1|
+ |$foreignsDefsForCLisp|)
+ (|d| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN
+ (SETQ |d| (CAR |bfVar#1|))
+ NIL))
(RETURN |bfVar#2|))
((NULL |bfVar#2|)
(SETQ |bfVar#2|
- #0=(CONS (CADR |d|)
- NIL))
- (SETQ |bfVar#3|
- |bfVar#2|))
- (T
- (RPLACD |bfVar#3| #0#)
+ #1=(CONS (CADR |d|)
+ NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
(SETQ |bfVar#3|
- (CDR |bfVar#3|))))
- (SETQ |bfVar#1|
- (CDR |bfVar#1|))))))
- (LET
- ((|bfVar#5| NIL)
- (|bfVar#6| NIL)
- (|bfVar#4|
- |$foreignsDefsForCLisp|)
- (|d| NIL))
- (LOOP
- (COND
- ((OR
- (NOT (CONSP |bfVar#4|))
- (PROGN
- (SETQ |d|
- (CAR |bfVar#4|))
- NIL))
- (RETURN |bfVar#5|))
- ((NULL |bfVar#5|)
- (SETQ |bfVar#5|
- #1=(CONS
- (LIST 'EVAL
- (|quote| |d|))
- NIL))
- (SETQ |bfVar#6|
- |bfVar#5|))
- (T (RPLACD |bfVar#6| #1#)
- (SETQ |bfVar#6|
- (CDR |bfVar#6|))))
- (SETQ |bfVar#4|
- (CDR |bfVar#4|)))))))))
+ (CDR |bfVar#3|))))
+ (SETQ |bfVar#1|
+ (CDR |bfVar#1|))))))
+ (LET ((|bfVar#5| NIL)
+ (|bfVar#6| NIL)
+ (|bfVar#4| |$foreignsDefsForCLisp|)
+ (|d| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#4|))
+ (PROGN
+ (SETQ |d| (CAR |bfVar#4|))
+ NIL))
+ (RETURN |bfVar#5|))
+ ((NULL |bfVar#5|)
+ (SETQ |bfVar#5|
+ #2=(CONS
+ (LIST 'EVAL (|quote| |d|))
+ NIL))
+ (SETQ |bfVar#6| |bfVar#5|))
+ (T (RPLACD |bfVar#6| #2#)
+ (SETQ |bfVar#6| (CDR |bfVar#6|))))
+ (SETQ |bfVar#4| (CDR |bfVar#4|)))))))))
(REALLYPRETTYPRINT |init| |stream|))))
- (T NIL)))))
+ (T NIL)))))
(DEFUN |genOptimizeOptions| (|stream|)
(REALLYPRETTYPRINT
- (LIST 'PROCLAIM
- (|quote| (CONS 'OPTIMIZE |$LispOptimizeOptions|)))
- |stream|))
+ (LIST 'PROCLAIM (|quote| (CONS 'OPTIMIZE |$LispOptimizeOptions|))) |stream|))
(DEFUN |AxiomCore|::|%sysInit| ()
(PROGN
- (SETQ *LOAD-VERBOSE* NIL)
- (COND
- ((|%hasFeature| :GCL)
- (SETF (SYMBOL-VALUE
- (|bfColonColon| 'COMPILER '*COMPILE-VERBOSE*))
- NIL)
- (SETF (SYMBOL-VALUE
- (|bfColonColon| 'COMPILER
- 'SUPPRESS-COMPILER-WARNINGS*))
+ (SETQ *LOAD-VERBOSE* NIL)
+ (COND
+ ((|%hasFeature| :GCL)
+ (SETF (SYMBOL-VALUE (|bfColonColon| 'COMPILER '*COMPILE-VERBOSE*)) NIL)
+ (SETF (SYMBOL-VALUE
+ (|bfColonColon| 'COMPILER 'SUPPRESS-COMPILER-WARNINGS*))
NIL)
- (SETF (SYMBOL-VALUE
- (|bfColonColon| 'COMPILER 'SUPPRESS-COMPILER-NOTES*))
+ (SETF (SYMBOL-VALUE (|bfColonColon| 'COMPILER 'SUPPRESS-COMPILER-NOTES*))
T)))))
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Thing|) |setCurrentPackage|))
@@ -127,299 +108,281 @@
(DECLAIM (FTYPE (FUNCTION (|%String|) |%Thing|) |shoeCOMPILE-FILE|))
-(DEFUN |shoeCOMPILE-FILE| (|lspFileName|)
- (COMPILE-FILE |lspFileName|))
+(DEFUN |shoeCOMPILE-FILE| (|lspFileName|) (COMPILE-FILE |lspFileName|))
(DEFUN BOOTTOCL (|fn| |out|)
(UNWIND-PROTECT
- (PROGN
- (|startCompileDuration|)
- (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
- (BOOTTOCLLINES NIL |fn| |out|)))
+ (PROGN
+ (|startCompileDuration|)
+ (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
+ (BOOTTOCLLINES NIL |fn| |out|)))
(|endCompileDuration|)))
(DEFUN BOOTCLAM (|fn| |out|)
(PROG (|$bfClamming|)
(DECLARE (SPECIAL |$bfClamming|))
- (RETURN
- (PROGN (SETQ |$bfClamming| T) (BOOTCLAMLINES NIL |fn| |out|)))))
+ (RETURN (PROGN (SETQ |$bfClamming| T) (BOOTCLAMLINES NIL |fn| |out|)))))
-(DEFUN BOOTCLAMLINES (|lines| |fn| |out|)
- (BOOTTOCLLINES |lines| |fn| |out|))
+(DEFUN BOOTCLAMLINES (|lines| |fn| |out|) (BOOTTOCLLINES |lines| |fn| |out|))
(DEFUN BOOTTOCLLINES (|lines| |fn| |outfn|)
(PROG (|a|)
(RETURN
- (UNWIND-PROTECT
- (PROGN
+ (UNWIND-PROTECT
+ (PROGN
(SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
(|shoeClLines| |a| |fn| |lines| |outfn|))
- (|closeStream| |a|)))))
+ (|closeStream| |a|)))))
(DEFUN |shoeClLines| (|a| |fn| |lines| |outfn|)
(PROG (|stream|)
(RETURN
- (COND
- ((NULL |a|) (|shoeNotFound| |fn|))
- (T (UNWIND-PROTECT
- (PROGN
- (SETQ |stream| (|outputTextFile| |outfn|))
- (|genOptimizeOptions| |stream|)
- (LET ((|bfVar#1| |lines|) (|line| NIL))
- (LOOP
- (COND
+ (COND ((NULL |a|) (|shoeNotFound| |fn|))
+ (T
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |stream| (|outputTextFile| |outfn|))
+ (|genOptimizeOptions| |stream|)
+ (LET ((|bfVar#1| |lines|) (|line| NIL))
+ (LOOP
+ (COND
((OR (NOT (CONSP |bfVar#1|))
(PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
(RETURN NIL))
(T (|shoeFileLine| |line| |stream|)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|)
- (|genModuleFinalization| |stream|)
- |outfn|)
- (|closeStream| |stream|)))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (|shoeFileTrees| (|shoeTransformStream| |a|) |stream|)
+ (|genModuleFinalization| |stream|)
+ |outfn|)
+ (|closeStream| |stream|)))))))
(DEFUN BOOTTOCLC (|fn| |out|)
(UNWIND-PROTECT
- (PROGN
- (|startCompileDuration|)
- (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
- (BOOTTOCLCLINES NIL |fn| |out|)))
+ (PROGN
+ (|startCompileDuration|)
+ (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
+ (BOOTTOCLCLINES NIL |fn| |out|)))
(|endCompileDuration|)))
(DEFUN BOOTTOCLCLINES (|lines| |fn| |outfn|)
(PROG (|a|)
(RETURN
- (UNWIND-PROTECT
- (PROGN
+ (UNWIND-PROTECT
+ (PROGN
(SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
(|shoeClCLines| |a| |fn| |lines| |outfn|))
- (|closeStream| |a|)))))
+ (|closeStream| |a|)))))
(DEFUN |shoeClCLines| (|a| |fn| |lines| |outfn|)
(PROG (|stream|)
(RETURN
- (COND
- ((NULL |a|) (|shoeNotFound| |fn|))
- (T (UNWIND-PROTECT
- (PROGN
- (SETQ |stream| (|outputTextFile| |outfn|))
- (|genOptimizeOptions| |stream|)
- (LET ((|bfVar#1| |lines|) (|line| NIL))
- (LOOP
- (COND
+ (COND ((NULL |a|) (|shoeNotFound| |fn|))
+ (T
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |stream| (|outputTextFile| |outfn|))
+ (|genOptimizeOptions| |stream|)
+ (LET ((|bfVar#1| |lines|) (|line| NIL))
+ (LOOP
+ (COND
((OR (NOT (CONSP |bfVar#1|))
(PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
(RETURN NIL))
(T (|shoeFileLine| |line| |stream|)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (|shoeFileTrees|
- (|shoeTransformToFile| |stream|
- (|shoeInclude|
- (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0))))
- |stream|)
- (|genModuleFinalization| |stream|)
- |outfn|)
- (|closeStream| |stream|)))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (|shoeFileTrees|
+ (|shoeTransformToFile| |stream|
+ (|shoeInclude|
+ (|bAddLineNumber| (|bRgen| |a|)
+ (|bIgen| 0))))
+ |stream|)
+ (|genModuleFinalization| |stream|)
+ |outfn|)
+ (|closeStream| |stream|)))))))
(DECLAIM (FTYPE (FUNCTION (|%String|) |%Thing|) BOOTTOMC))
(DEFUN BOOTTOMC (|fn|)
(PROG (|a| |callingPackage|)
(RETURN
- (PROGN
- (SETQ |callingPackage| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (UNWIND-PROTECT
- (PROGN
- (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
- (|shoeMc| |a| |fn|))
+ (PROGN
+ (SETQ |callingPackage| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (UNWIND-PROTECT
(PROGN
- (|closeStream| |a|)
- (|setCurrentPackage| |callingPackage|)))))))
+ (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
+ (|shoeMc| |a| |fn|))
+ (PROGN (|closeStream| |a|) (|setCurrentPackage| |callingPackage|)))))))
(DEFUN |shoeMc| (|a| |fn|)
- (COND
- ((NULL |a|) (|shoeNotFound| |fn|))
- (T (|shoePCompileTrees| (|shoeTransformStream| |a|))
- (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED")))))
+ (COND ((NULL |a|) (|shoeNotFound| |fn|))
+ (T (|shoePCompileTrees| (|shoeTransformStream| |a|))
+ (|shoeConsole| (CONCAT |fn| " COMPILED AND LOADED")))))
(DEFUN |evalBootFile| (|fn|)
(PROG (|a| |outfn| |infn| |b|)
(RETURN
- (PROGN
- (SETQ |b| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (SETQ |infn| (|shoeAddbootIfNec| |fn|))
- (SETQ |outfn|
- (CONCAT (|shoeRemovebootIfNec| |fn|) "."
- *LISP-SOURCE-FILETYPE*))
- (UNWIND-PROTECT
+ (PROGN
+ (SETQ |b| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (SETQ |infn| (|shoeAddbootIfNec| |fn|))
+ (SETQ |outfn|
+ (CONCAT (|shoeRemovebootIfNec| |fn|) "." *LISP-SOURCE-FILETYPE*))
+ (UNWIND-PROTECT
(PROGN
- (SETQ |a| (|inputTextFile| |infn|))
- (|shoeClLines| |a| |infn| NIL |outfn|))
- (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|)))
- (LOAD |outfn|)))))
+ (SETQ |a| (|inputTextFile| |infn|))
+ (|shoeClLines| |a| |infn| NIL |outfn|))
+ (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|)))
+ (LOAD |outfn|)))))
(DECLAIM (FTYPE (FUNCTION (|%String|) |%Thing|) BO))
(DEFUN BO (|fn|)
(PROG (|a| |b|)
(RETURN
- (PROGN
- (SETQ |b| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (UNWIND-PROTECT
+ (PROGN
+ (SETQ |b| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (UNWIND-PROTECT
(PROGN
- (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
- (|shoeToConsole| |a| |fn|))
- (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|)))))))
+ (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
+ (|shoeToConsole| |a| |fn|))
+ (PROGN (|closeStream| |a|) (|setCurrentPackage| |b|)))))))
(DEFUN BOCLAM (|fn|)
(PROG (|$bfClamming| |a| |callingPackage|)
(DECLARE (SPECIAL |$bfClamming|))
(RETURN
- (PROGN
- (SETQ |callingPackage| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (SETQ |$bfClamming| T)
- (UNWIND-PROTECT
- (PROGN
- (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
- (|shoeToConsole| |a| |fn|))
+ (PROGN
+ (SETQ |callingPackage| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (SETQ |$bfClamming| T)
+ (UNWIND-PROTECT
(PROGN
- (|closeStream| |a|)
- (|setCurrentPackage| |callingPackage|)))))))
+ (SETQ |a| (|inputTextFile| (|shoeAddbootIfNec| |fn|)))
+ (|shoeToConsole| |a| |fn|))
+ (PROGN (|closeStream| |a|) (|setCurrentPackage| |callingPackage|)))))))
(DEFUN |shoeToConsole| (|a| |fn|)
- (COND
- ((NULL |a|) (|shoeNotFound| |fn|))
- (T (|shoeConsoleTrees|
- (|shoeTransformToConsole|
- (|shoeInclude|
- (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0))))))))
+ (COND ((NULL |a|) (|shoeNotFound| |fn|))
+ (T
+ (|shoeConsoleTrees|
+ (|shoeTransformToConsole|
+ (|shoeInclude| (|bAddLineNumber| (|bRgen| |a|) (|bIgen| 0))))))))
(DEFUN STOUT (|string|) (PSTOUT (LIST |string|)))
(DEFUN |string2BootTree| (|string|)
(PROG (|result| |a| |callingPackage|)
(RETURN
- (PROGN
- (SETQ |callingPackage| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (SETQ |a| (|shoeTransformString| (LIST |string|)))
- (SETQ |result|
- (COND
- ((|bStreamNull| |a|) NIL)
- (T (|stripm| (CAR |a|) |callingPackage|
- (FIND-PACKAGE "BOOTTRAN")))))
- (|setCurrentPackage| |callingPackage|)
- |result|))))
+ (PROGN
+ (SETQ |callingPackage| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (SETQ |a| (|shoeTransformString| (LIST |string|)))
+ (SETQ |result|
+ (COND ((|bStreamNull| |a|) NIL)
+ (T
+ (|stripm| (CAR |a|) |callingPackage|
+ (FIND-PACKAGE "BOOTTRAN")))))
+ (|setCurrentPackage| |callingPackage|)
+ |result|))))
(DEFUN STEVAL (|string|)
(PROG (|result| |fn| |a| |callingPackage|)
(RETURN
- (PROGN
- (SETQ |callingPackage| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (SETQ |a| (|shoeTransformString| (LIST |string|)))
- (SETQ |result|
- (COND
- ((|bStreamNull| |a|) NIL)
- (T (SETQ |fn|
- (|stripm| (CAR |a|) *PACKAGE*
- (FIND-PACKAGE "BOOTTRAN")))
- (EVAL |fn|))))
- (|setCurrentPackage| |callingPackage|)
- |result|))))
+ (PROGN
+ (SETQ |callingPackage| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (SETQ |a| (|shoeTransformString| (LIST |string|)))
+ (SETQ |result|
+ (COND ((|bStreamNull| |a|) NIL)
+ (T
+ (SETQ |fn|
+ (|stripm| (CAR |a|) *PACKAGE*
+ (FIND-PACKAGE "BOOTTRAN")))
+ (EVAL |fn|))))
+ (|setCurrentPackage| |callingPackage|)
+ |result|))))
(DEFUN STTOMC (|string|)
(PROG (|result| |a| |callingPackage|)
(RETURN
- (PROGN
- (SETQ |callingPackage| *PACKAGE*)
- (IN-PACKAGE "BOOTTRAN")
- (SETQ |a| (|shoeTransformString| (LIST |string|)))
- (SETQ |result|
- (COND
- ((|bStreamNull| |a|) NIL)
- (T (|shoePCompile| (CAR |a|)))))
- (|setCurrentPackage| |callingPackage|)
- |result|))))
+ (PROGN
+ (SETQ |callingPackage| *PACKAGE*)
+ (IN-PACKAGE "BOOTTRAN")
+ (SETQ |a| (|shoeTransformString| (LIST |string|)))
+ (SETQ |result|
+ (COND ((|bStreamNull| |a|) NIL) (T (|shoePCompile| (CAR |a|)))))
+ (|setCurrentPackage| |callingPackage|)
+ |result|))))
(DEFUN |shoeCompileTrees| (|s|)
(LOOP
- (COND
- ((|bStreamNull| |s|) (RETURN NIL))
- (T (|shoeCompile| (CAR |s|)) (SETQ |s| (CDR |s|))))))
+ (COND ((|bStreamNull| |s|) (RETURN NIL))
+ (T (|shoeCompile| (CAR |s|)) (SETQ |s| (CDR |s|))))))
(DECLAIM (FTYPE (FUNCTION (|%Ast|) |%Thing|) |shoeCompile|))
(DEFUN |shoeCompile| (|fn|)
(PROG (|body| |bv| |ISTMP#2| |name| |ISTMP#1|)
(RETURN
- (COND
- ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN)
- (PROGN
- (SETQ |ISTMP#1| (CDR |fn|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |name| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (PROGN
- (SETQ |bv| (CAR |ISTMP#2|))
- (SETQ |body| (CDR |ISTMP#2|))
- T))))))
- (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|))))
- (T (EVAL |fn|))))))
+ (COND
+ ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |fn|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |name| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (PROGN
+ (SETQ |bv| (CAR |ISTMP#2|))
+ (SETQ |body| (CDR |ISTMP#2|))
+ T))))))
+ (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|))))
+ (T (EVAL |fn|))))))
(DEFUN |shoeTransform| (|str|)
(|bNext| #'|shoeTreeConstruct|
- (|bNext| #'|shoePileInsert|
- (|bNext| #'|shoeLineToks| |str|))))
+ (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|))))
(DEFUN |shoeTransformString| (|s|)
(|shoeTransform| (|shoeInclude| (|bAddLineNumber| |s| (|bIgen| 0)))))
-(DEFUN |shoeTransformStream| (|s|)
- (|shoeTransformString| (|bRgen| |s|)))
+(DEFUN |shoeTransformStream| (|s|) (|shoeTransformString| (|bRgen| |s|)))
(DEFUN |shoeTransformToConsole| (|str|)
(|bNext| #'|shoeConsoleItem|
- (|bNext| #'|shoePileInsert|
- (|bNext| #'|shoeLineToks| |str|))))
+ (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|))))
(DEFUN |shoeTransformToFile| (|fn| |str|)
(|bFileNext| |fn|
- (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|))))
+ (|bNext| #'|shoePileInsert| (|bNext| #'|shoeLineToks| |str|))))
(DEFUN |shoeConsoleItem| (|str|)
(PROG (|dq|)
(RETURN
- (PROGN
- (SETQ |dq| (CAR |str|))
- (|shoeConsoleLines| (|shoeDQlines| |dq|))
- (CONS (|shoeParseTrees| |dq|) (CDR |str|))))))
+ (PROGN
+ (SETQ |dq| (CAR |str|))
+ (|shoeConsoleLines| (|shoeDQlines| |dq|))
+ (CONS (|shoeParseTrees| |dq|) (CDR |str|))))))
-(DEFUN |bFileNext| (|fn| |s|)
- (|bDelay| #'|bFileNext1| (LIST |fn| |s|)))
+(DEFUN |bFileNext| (|fn| |s|) (|bDelay| #'|bFileNext1| (LIST |fn| |s|)))
(DEFUN |bFileNext1| (|fn| |s|)
(PROG (|dq|)
(RETURN
- (COND
- ((|bStreamNull| |s|) (LIST '|nullstream|))
- (T (SETQ |dq| (CAR |s|))
- (|shoeFileLines| (|shoeDQlines| |dq|) |fn|)
- (|bAppend| (|shoeParseTrees| |dq|)
- (|bFileNext| |fn| (CDR |s|))))))))
+ (COND ((|bStreamNull| |s|) (LIST '|nullstream|))
+ (T (SETQ |dq| (CAR |s|)) (|shoeFileLines| (|shoeDQlines| |dq|) |fn|)
+ (|bAppend| (|shoeParseTrees| |dq|)
+ (|bFileNext| |fn| (CDR |s|))))))))
(DEFUN |shoeParseTrees| (|dq|)
(PROG (|toklist|)
(RETURN
- (PROGN
- (SETQ |toklist| (|dqToList| |dq|))
- (COND ((NULL |toklist|) NIL) (T (|shoeOutParse| |toklist|)))))))
+ (PROGN
+ (SETQ |toklist| (|dqToList| |dq|))
+ (COND ((NULL |toklist|) NIL) (T (|shoeOutParse| |toklist|)))))))
(DEFUN |shoeTreeConstruct| (|str|)
(CONS (|shoeParseTrees| (CAR |str|)) (CDR |str|)))
@@ -427,58 +390,51 @@
(DEFUN |shoeDQlines| (|dq|)
(PROG (|b| |a|)
(RETURN
- (PROGN
- (SETQ |a| (CDAAR (|shoeLastTokPosn| |dq|)))
- (SETQ |b| (CDAAR (|shoeFirstTokPosn| |dq|)))
- (|streamTake| (+ (- |a| |b|) 1)
- (CAR (|shoeFirstTokPosn| |dq|)))))))
+ (PROGN
+ (SETQ |a| (CDAAR (|shoeLastTokPosn| |dq|)))
+ (SETQ |b| (CDAAR (|shoeFirstTokPosn| |dq|)))
+ (|streamTake| (+ (- |a| |b|) 1) (CAR (|shoeFirstTokPosn| |dq|)))))))
(DEFUN |streamTake| (|n| |s|)
- (COND
- ((|bStreamNull| |s|) NIL)
- ((EQL |n| 0) NIL)
- (T (CONS (CAR |s|) (|streamTake| (- |n| 1) (CDR |s|))))))
+ (COND ((|bStreamNull| |s|) NIL) ((EQL |n| 0) NIL)
+ (T (CONS (CAR |s|) (|streamTake| (- |n| 1) (CDR |s|))))))
(DEFUN |shoeFileLines| (|lines| |fn|)
(PROGN
- (|shoeFileLine| " " |fn|)
- (LET ((|bfVar#1| |lines|) (|line| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (|shoeFileLine| (|shoeAddComment| |line|) |fn|)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (|shoeFileLine| " " |fn|)))
+ (|shoeFileLine| " " |fn|)
+ (LET ((|bfVar#1| |lines|) (|line| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (|shoeFileLine| (|shoeAddComment| |line|) |fn|)))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (|shoeFileLine| " " |fn|)))
(DEFUN |shoeConsoleLines| (|lines|)
(PROGN
- (|shoeConsole| " ")
- (LET ((|bfVar#1| |lines|) (|line| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (|shoeConsole| (|shoeAddComment| |line|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (|shoeConsole| " ")))
+ (|shoeConsole| " ")
+ (LET ((|bfVar#1| |lines|) (|line| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (|shoeConsole| (|shoeAddComment| |line|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (|shoeConsole| " ")))
-(DEFUN |shoeFileLine| (|x| |stream|)
- (PROGN (WRITE-LINE |x| |stream|) |x|))
+(DEFUN |shoeFileLine| (|x| |stream|) (PROGN (WRITE-LINE |x| |stream|) |x|))
(DEFUN |shoeFileTrees| (|s| |st|)
(PROG (|a|)
(RETURN
- (LOOP
- (COND
- ((|bStreamNull| |s|) (RETURN NIL))
- (T (SETQ |a| (CAR |s|))
+ (LOOP
+ (COND ((|bStreamNull| |s|) (RETURN NIL))
+ (T (SETQ |a| (CAR |s|))
(COND
- ((AND (CONSP |a|) (EQ (CAR |a|) '+LINE))
- (|shoeFileLine| (CADR |a|) |st|))
- (T (REALLYPRETTYPRINT |a| |st|) (TERPRI |st|)))
+ ((AND (CONSP |a|) (EQ (CAR |a|) '+LINE))
+ (|shoeFileLine| (CADR |a|) |st|))
+ (T (REALLYPRETTYPRINT |a| |st|) (TERPRI |st|)))
(SETQ |s| (CDR |s|))))))))
(DEFUN |shoePPtoFile| (|x| |stream|)
@@ -487,313 +443,291 @@
(DEFUN |shoeConsoleTrees| (|s|)
(PROG (|fn|)
(RETURN
- (LOOP
- (COND
- ((|bStreamPackageNull| |s|) (RETURN NIL))
- (T (SETQ |fn|
- (|stripm| (CAR |s|) *PACKAGE*
- (FIND-PACKAGE "BOOTTRAN")))
+ (LOOP
+ (COND ((|bStreamPackageNull| |s|) (RETURN NIL))
+ (T
+ (SETQ |fn|
+ (|stripm| (CAR |s|) *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
(REALLYPRETTYPRINT |fn|) (SETQ |s| (CDR |s|))))))))
(DEFUN |shoeAddComment| (|l|) (CONCAT "; " (CAR |l|)))
(DEFUN |shoeOutParse| (|stream|)
(PROG (|found|)
- (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$returns| |$typings|
- |$wheredefs| |$op| |$ttok| |$stok| |$stack|
- |$inputStream|))
+ (DECLARE
+ (SPECIAL |$inputStream| |$stack| |$stok| |$ttok| |$op| |$wheredefs|
+ |$typings| |$returns| |$bpCount| |$bpParenCount|))
(RETURN
- (PROGN
- (SETQ |$inputStream| |stream|)
- (SETQ |$stack| NIL)
- (SETQ |$stok| NIL)
- (SETQ |$ttok| NIL)
- (SETQ |$op| NIL)
- (SETQ |$wheredefs| NIL)
- (SETQ |$typings| NIL)
- (SETQ |$returns| NIL)
- (SETQ |$bpCount| 0)
- (SETQ |$bpParenCount| 0)
- (|bpFirstTok|)
- (SETQ |found|
- (LET ((#0=#:G1364
- (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem|))))
+ (PROGN
+ (SETQ |$inputStream| |stream|)
+ (SETQ |$stack| NIL)
+ (SETQ |$stok| NIL)
+ (SETQ |$ttok| NIL)
+ (SETQ |$op| NIL)
+ (SETQ |$wheredefs| NIL)
+ (SETQ |$typings| NIL)
+ (SETQ |$returns| NIL)
+ (SETQ |$bpCount| 0)
+ (SETQ |$bpParenCount| 0)
+ (|bpFirstTok|)
+ (SETQ |found|
+ (LET ((#1=#:G729 (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem|))))
(COND
- ((AND (CONSP #0#)
- (EQUAL (CAR #0#) :OPEN-AXIOM-CATCH-POINT))
- (COND
- ((EQUAL (CAR #1=(CDR #0#))
- '(|BootParserException|))
- (LET ((|e| (CDR #1#))) |e|))
- (T (THROW :OPEN-AXIOM-CATCH-POINT #0#))))
- (T #0#))))
- (COND
- ((EQ |found| 'TRAPPED) NIL)
- ((NOT (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|)
- NIL)
- ((NULL |$stack|) (|bpGeneralErrorHere|) NIL)
- (T (CAR |$stack|)))))))
+ ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT))
+ (COND
+ ((EQUAL (CAR #2=(CDR #1#)) '(|BootParserException|))
+ (LET ((|e| (CDR #2#)))
+ |e|))
+ (T (THROW :OPEN-AXIOM-CATCH-POINT #1#))))
+ (T #1#))))
+ (COND ((EQ |found| 'TRAPPED) NIL)
+ ((NOT (|bStreamNull| |$inputStream|)) (|bpGeneralErrorHere|) NIL)
+ ((NULL |$stack|) (|bpGeneralErrorHere|) NIL) (T (CAR |$stack|)))))))
(DEFUN |genDeclaration| (|n| |t|)
(PROG (|t'| |vars| |argTypes| |ISTMP#2| |valType| |ISTMP#1|)
(RETURN
- (COND
- ((AND (CONSP |t|) (EQ (CAR |t|) '|%Mapping|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |t|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |valType| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN
- (SETQ |argTypes| (CAR |ISTMP#2|))
- T))))))
- (COND
- ((|bfTupleP| |argTypes|) (SETQ |argTypes| (CDR |argTypes|))))
- (COND
- ((AND |argTypes| (SYMBOLP |argTypes|))
- (SETQ |argTypes| (LIST |argTypes|))))
- (LIST 'DECLAIM
- (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|) |n|)))
- ((AND (CONSP |t|) (EQ (CAR |t|) '|%Forall|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |t|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |vars| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
- (PROGN (SETQ |t'| (CAR |ISTMP#2|)) T))))))
- (COND
- ((NULL |vars|) (|genDeclaration| |n| |t'|))
- (T (COND ((SYMBOLP |vars|) (SETQ |vars| (LIST |vars|))))
+ (COND
+ ((AND (CONSP |t|) (EQ (CAR |t|) '|%Mapping|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |t|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |valType| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |argTypes| (CAR |ISTMP#2|)) T))))))
+ (COND ((|bfTupleP| |argTypes|) (SETQ |argTypes| (CDR |argTypes|))))
+ (COND
+ ((AND |argTypes| (SYMBOLP |argTypes|))
+ (SETQ |argTypes| (LIST |argTypes|))))
+ (LIST 'DECLAIM (LIST 'FTYPE (LIST 'FUNCTION |argTypes| |valType|) |n|)))
+ ((AND (CONSP |t|) (EQ (CAR |t|) '|%Forall|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |t|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |vars| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |t'| (CAR |ISTMP#2|)) T))))))
+ (COND ((NULL |vars|) (|genDeclaration| |n| |t'|))
+ (T (COND ((SYMBOLP |vars|) (SETQ |vars| (LIST |vars|))))
(|genDeclaration| |n|
- (|applySubst|
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL)
- (|bfVar#1| |vars|) (|v| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN
- (SETQ |v| (CAR |bfVar#1|))
- NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #0=(CONS (CONS |v| '*) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- |t'|)))))
- (T (LIST 'DECLAIM (LIST 'TYPE |t| |n|)))))))
+ (|applySubst|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |vars|)
+ (|v| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN
+ (SETQ |v| (CAR |bfVar#1|))
+ NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2|
+ #1=(CONS (CONS |v| '*) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ |t'|)))))
+ (T (LIST 'DECLAIM (LIST 'TYPE |t| |n|)))))))
(DEFUN |translateSignatureDeclaration| (|d|)
(CASE (CAR |d|)
(|%Signature|
- (LET ((|n| (CADR |d|)) (|t| (CADDR |d|)))
- (|genDeclaration| |n| |t|)))
+ (LET ((|n| (CADR |d|)) (|t| (CADDR |d|)))
+ (|genDeclaration| |n| |t|)))
(T (|coreError| "signature expected"))))
(DEFUN |translateToplevelExpression| (|expr|)
(PROG (|expr'|)
(RETURN
- (PROGN
- (SETQ |expr'|
- (CDR (CDR (|shoeCompTran| (LIST 'LAMBDA NIL |expr|)))))
- (LET ((|bfVar#1| |expr'|) (|t| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- ((AND (CONSP |t|) (EQ (CAR |t|) 'DECLARE))
- (IDENTITY (RPLACA |t| 'DECLAIM))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (COND
- ((< 1 (LENGTH |expr'|)) (CONS 'PROGN |expr'|))
- (T (CAR |expr'|)))))))
+ (PROGN
+ (SETQ |expr'| (CDR (CDR (|shoeCompTran| (LIST 'LAMBDA NIL |expr|)))))
+ (LET ((|bfVar#1| |expr'|) (|t| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |t| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ ((AND (CONSP |t|) (EQ (CAR |t|) 'DECLARE))
+ (IDENTITY (RPLACA |t| 'DECLAIM))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (COND ((< 1 (LENGTH |expr'|)) (CONS 'PROGN |expr'|))
+ (T (CAR |expr'|)))))))
(DEFUN |inAllContexts| (|x|)
- (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
- |x|))
+ (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE) |x|))
(DEFUN |exportNames| (|ns|)
- (COND
- ((NULL |ns|) NIL)
- (T (LIST (|inAllContexts| (LIST 'EXPORT (|quote| |ns|)))))))
+ (COND ((NULL |ns|) NIL)
+ (T (LIST (|inAllContexts| (LIST 'EXPORT (|quote| |ns|)))))))
(DEFUN |translateToplevel| (|b| |export?|)
(PROG (|lhs| |t| |ISTMP#2| |sig| |n| |ISTMP#1| |xs|)
- (DECLARE (SPECIAL |$activeNamespace| |$InteractiveMode|
- |$constantIdentifiers| |$foreignsDefsForCLisp|
- |$currentModuleName|))
+ (DECLARE
+ (SPECIAL |$currentModuleName| |$foreignsDefsForCLisp|
+ |$constantIdentifiers| |$InteractiveMode| |$activeNamespace|))
(RETURN
- (COND
- ((NOT (CONSP |b|)) (LIST |b|))
- ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE)) (SETQ |xs| (CDR |b|))
- (|coreError| "invalid AST"))
- (T (CASE (CAR |b|)
- (|%Signature|
- (LET ((|op| (CADR |b|)) (|t| (CADDR |b|)))
- (LIST (|genDeclaration| |op| |t|))))
- (|%Definition|
- (LET ((|op| (CADR |b|)) (|args| (CADDR |b|))
- (|body| (CADDDR |b|)))
- (CDR (|bfDef| |op| |args| |body|))))
- (|%Module|
- (LET ((|m| (CADR |b|)) (|ns| (CADDR |b|))
- (|ds| (CADDDR |b|)))
- (PROGN
- (SETQ |$currentModuleName| |m|)
- (SETQ |$foreignsDefsForCLisp| NIL)
- (CONS (LIST 'PROVIDE (SYMBOL-NAME |m|))
- (|append| (|exportNames| |ns|)
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL)
- (|bfVar#1| |ds|) (|d| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN
- (SETQ |d| (CAR |bfVar#1|))
- NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2|
- #0=(CONS
- (CAR
- (|translateToplevel| |d| T))
- NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))))))
- (|%Import|
- (LET ((|m| (CADR |b|)))
+ (COND ((NOT (CONSP |b|)) (LIST |b|))
+ ((AND (CONSP |b|) (EQ (CAR |b|) 'TUPLE)) (SETQ |xs| (CDR |b|))
+ (|coreError| "invalid AST"))
+ (T
+ (CASE (CAR |b|)
+ (|%Signature|
+ (LET ((|op| (CADR |b|)) (|t| (CADDR |b|)))
+ (LIST (|genDeclaration| |op| |t|))))
+ (|%Definition|
+ (LET ((|op| (CADR |b|))
+ (|args| (CADDR |b|))
+ (|body| (CADDDR |b|)))
+ (CDR (|bfDef| |op| |args| |body|))))
+ (|%Module|
+ (LET ((|m| (CADR |b|)) (|ns| (CADDR |b|)) (|ds| (CADDDR |b|)))
+ (PROGN
+ (SETQ |$currentModuleName| |m|)
+ (SETQ |$foreignsDefsForCLisp| NIL)
+ (CONS (LIST 'PROVIDE (SYMBOL-NAME |m|))
+ (|append| (|exportNames| |ns|)
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| |ds|)
+ (|d| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN
+ (SETQ |d| (CAR |bfVar#1|))
+ NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|)
+ (SETQ |bfVar#2|
+ #1=(CONS
+ (CAR
+ (|translateToplevel| |d|
+ T))
+ NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))))))
+ (|%Import|
+ (LET ((|m| (CADR |b|)))
+ (COND
+ ((AND (CONSP |m|) (EQ (CAR |m|) '|%Namespace|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |m|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |n| (CAR |ISTMP#1|)) T))))
+ (LIST
+ (|inAllContexts| (LIST 'USE-PACKAGE (SYMBOL-NAME |n|)))))
+ (T
(COND
- ((AND (CONSP |m|) (EQ (CAR |m|) '|%Namespace|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |m|))
- (AND (CONSP |ISTMP#1|)
- (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |n| (CAR |ISTMP#1|)) T))))
- (LIST (|inAllContexts|
- (LIST 'USE-PACKAGE (SYMBOL-NAME |n|)))))
- (T (COND
- ((NOT (STRING= (|getOptionValue| '|import|)
- "skip"))
- (|bootImport| (SYMBOL-NAME |m|))))
- (LIST (LIST 'IMPORT-MODULE (SYMBOL-NAME |m|)))))))
- (|%ImportSignature|
- (LET ((|x| (CADR |b|)) (|sig| (CADDR |b|)))
- (|genImportDeclaration| |x| |sig|)))
- (|%TypeAlias|
- (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
- (LIST (|genTypeAlias| |lhs| |rhs|))))
- (|%ConstantDefinition|
- (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
- (PROGN
- (SETQ |sig| NIL)
- (COND
- ((AND (CONSP |lhs|)
- (EQ (CAR |lhs|) '|%Signature|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |n| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (NULL (CDR |ISTMP#2|))
- (PROGN
- (SETQ |t| (CAR |ISTMP#2|))
- T))))))
- (SETQ |sig| (|genDeclaration| |n| |t|))
- (SETQ |lhs| |n|)))
- (SETQ |$constantIdentifiers|
- (CONS |lhs| |$constantIdentifiers|))
- (LIST (LIST 'DEFCONSTANT |lhs| |rhs|)))))
- (|%Assignment|
- (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
- (PROGN
- (SETQ |sig| NIL)
- (COND
- ((AND (CONSP |lhs|)
- (EQ (CAR |lhs|) '|%Signature|)
- (PROGN
- (SETQ |ISTMP#1| (CDR |lhs|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |n| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (NULL (CDR |ISTMP#2|))
- (PROGN
- (SETQ |t| (CAR |ISTMP#2|))
- T))))))
- (SETQ |sig| (|genDeclaration| |n| |t|))
- (SETQ |lhs| |n|)))
- (COND
- (|$InteractiveMode|
- (LIST (LIST 'SETF |lhs| |rhs|)))
- (T (LIST (LIST 'DEFPARAMETER |lhs| |rhs|)))))))
- (|%Macro|
- (LET ((|op| (CADR |b|)) (|args| (CADDR |b|))
- (|body| (CADDDR |b|)))
- (|bfMDef| |op| |args| |body|)))
- (|%Structure|
- (LET ((|t| (CADR |b|)) (|alts| (CADDR |b|)))
- (LET ((|bfVar#5| NIL) (|bfVar#6| NIL)
- (|bfVar#4| |alts|) (|alt| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#4|))
- (PROGN (SETQ |alt| (CAR |bfVar#4|)) NIL))
- (RETURN |bfVar#5|))
- ((NULL |bfVar#5|)
- (SETQ |bfVar#5|
- #1=(CONS (|bfCreateDef| |alt|) NIL))
- (SETQ |bfVar#6| |bfVar#5|))
- (T (RPLACD |bfVar#6| #1#)
- (SETQ |bfVar#6| (CDR |bfVar#6|))))
- (SETQ |bfVar#4| (CDR |bfVar#4|))))))
- (|%Namespace|
- (LET ((|n| (CADR |b|)))
- (PROGN
- (SETQ |$activeNamespace| (SYMBOL-NAME |n|))
- (LIST (LIST 'IN-PACKAGE (SYMBOL-NAME |n|))))))
- (|%Lisp| (LET ((|s| (CADR |b|)))
- (|shoeReadLispString| |s| 0)))
- (T (LIST (|translateToplevelExpression| |b|)))))))))
+ ((NOT (STRING= (|getOptionValue| '|import|) "skip"))
+ (|bootImport| (SYMBOL-NAME |m|))))
+ (LIST (LIST 'IMPORT-MODULE (SYMBOL-NAME |m|)))))))
+ (|%ImportSignature|
+ (LET ((|x| (CADR |b|)) (|sig| (CADDR |b|)))
+ (|genImportDeclaration| |x| |sig|)))
+ (|%TypeAlias|
+ (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
+ (LIST (|genTypeAlias| |lhs| |rhs|))))
+ (|%ConstantDefinition|
+ (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
+ (PROGN
+ (SETQ |sig| NIL)
+ (COND
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |n| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |t| (CAR |ISTMP#2|)) T))))))
+ (SETQ |sig| (|genDeclaration| |n| |t|)) (SETQ |lhs| |n|)))
+ (SETQ |$constantIdentifiers|
+ (CONS |lhs| |$constantIdentifiers|))
+ (LIST (LIST 'DEFCONSTANT |lhs| |rhs|)))))
+ (|%Assignment|
+ (LET ((|lhs| (CADR |b|)) (|rhs| (CADDR |b|)))
+ (PROGN
+ (SETQ |sig| NIL)
+ (COND
+ ((AND (CONSP |lhs|) (EQ (CAR |lhs|) '|%Signature|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |lhs|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |n| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |t| (CAR |ISTMP#2|)) T))))))
+ (SETQ |sig| (|genDeclaration| |n| |t|)) (SETQ |lhs| |n|)))
+ (COND (|$InteractiveMode| (LIST (LIST 'SETF |lhs| |rhs|)))
+ (T (LIST (LIST 'DEFPARAMETER |lhs| |rhs|)))))))
+ (|%Macro|
+ (LET ((|op| (CADR |b|))
+ (|args| (CADDR |b|))
+ (|body| (CADDDR |b|)))
+ (|bfMDef| |op| |args| |body|)))
+ (|%Structure|
+ (LET ((|t| (CADR |b|)) (|alts| (CADDR |b|)))
+ (LET ((|bfVar#5| NIL)
+ (|bfVar#6| NIL)
+ (|bfVar#4| |alts|)
+ (|alt| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#4|))
+ (PROGN (SETQ |alt| (CAR |bfVar#4|)) NIL))
+ (RETURN |bfVar#5|))
+ ((NULL |bfVar#5|)
+ (SETQ |bfVar#5| #2=(CONS (|bfCreateDef| |alt|) NIL))
+ (SETQ |bfVar#6| |bfVar#5|))
+ (T (RPLACD |bfVar#6| #2#)
+ (SETQ |bfVar#6| (CDR |bfVar#6|))))
+ (SETQ |bfVar#4| (CDR |bfVar#4|))))))
+ (|%Namespace|
+ (LET ((|n| (CADR |b|)))
+ (PROGN
+ (SETQ |$activeNamespace| (SYMBOL-NAME |n|))
+ (LIST (LIST 'IN-PACKAGE (SYMBOL-NAME |n|))))))
+ (|%Lisp|
+ (LET ((|s| (CADR |b|)))
+ (|shoeReadLispString| |s| 0)))
+ (T (LIST (|translateToplevelExpression| |b|)))))))))
(DEFUN |shoeAddbootIfNec| (|s|) (|shoeAddStringIfNec| ".boot" |s|))
-(DEFUN |shoeRemovebootIfNec| (|s|)
- (|shoeRemoveStringIfNec| ".boot" |s|))
+(DEFUN |shoeRemovebootIfNec| (|s|) (|shoeRemoveStringIfNec| ".boot" |s|))
(DEFUN |shoeAddStringIfNec| (|str| |s|)
(PROG (|a|)
(RETURN
- (PROGN
- (SETQ |a| (STRPOS |str| |s| 0 NIL))
- (COND ((NULL |a|) (CONCAT |s| |str|)) (T |s|))))))
+ (PROGN
+ (SETQ |a| (STRPOS |str| |s| 0 NIL))
+ (COND ((NULL |a|) (CONCAT |s| |str|)) (T |s|))))))
(DEFUN |shoeRemoveStringIfNec| (|str| |s|)
(PROG (|n|)
(RETURN
- (PROGN
- (SETQ |n| (SEARCH |str| |s| :FROM-END T))
- (COND ((NULL |n|) |s|) (T (|subString| |s| 0 |n|)))))))
+ (PROGN
+ (SETQ |n| (SEARCH |str| |s| :FROM-END T))
+ (COND ((NULL |n|) |s|) (T (|subString| |s| 0 |n|)))))))
(DEFUN DEFUSE (|fn|)
(PROG (|a|)
(RETURN
- (UNWIND-PROTECT
- (PROGN
+ (UNWIND-PROTECT
+ (PROGN
(SETQ |a| (|inputTextFile| (CONCAT |fn| ".boot")))
(|shoeDfu| |a| |fn|))
- (|closeStream| |a|)))))
+ (|closeStream| |a|)))))
(DEFPARAMETER |$bootDefined| NIL)
@@ -805,266 +739,250 @@
(DEFUN |shoeDfu| (|a| |fn|)
(PROG (|$bfClamming| |$bootDefinedTwice| |$bootUsed| |$bootDefined|
- |$lispWordTable| |stream|)
- (DECLARE (SPECIAL |$bfClamming| |$bootDefinedTwice| |$bootUsed|
- |$bootDefined| |$lispWordTable|))
+ |$lispWordTable| |stream|)
+ (DECLARE
+ (SPECIAL |$bootDefined| |$bootUsed| |$bootDefinedTwice| |$bfClamming|
+ |$lispWordTable|))
(RETURN
- (COND
- ((NULL |a|) (|shoeNotFound| |fn|))
- (T (SETQ |$lispWordTable| (|makeTable| #'EQ))
- (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP"))
- (SETF (|tableValue| |$lispWordTable| |i|) T))
- (SETQ |$bootDefined| (|makeTable| #'EQ))
- (SETQ |$bootUsed| (|makeTable| #'EQ))
- (SETQ |$bootDefinedTwice| NIL) (SETQ |$bfClamming| NIL)
- (|shoeDefUse| (|shoeTransformStream| |a|))
- (UNWIND-PROTECT
- (PROGN
- (SETQ |stream|
- (|outputTextFile| (CONCAT |fn| ".defuse")))
- (|shoeReport| |stream|))
- (|closeStream| |stream|)))))))
+ (COND ((NULL |a|) (|shoeNotFound| |fn|))
+ (T (SETQ |$lispWordTable| (|makeTable| #'EQ))
+ (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP"))
+ (SETF (|tableValue| |$lispWordTable| |i|) T))
+ (SETQ |$bootDefined| (|makeTable| #'EQ))
+ (SETQ |$bootUsed| (|makeTable| #'EQ))
+ (SETQ |$bootDefinedTwice| NIL) (SETQ |$bfClamming| NIL)
+ (|shoeDefUse| (|shoeTransformStream| |a|))
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |stream| (|outputTextFile| (CONCAT |fn| ".defuse")))
+ (|shoeReport| |stream|))
+ (|closeStream| |stream|)))))))
(DEFUN |shoeReport| (|stream|)
(PROG (|b| |a|)
- (DECLARE (SPECIAL |$bootDefinedTwice| |$bootUsed| |$bootDefined|))
+ (DECLARE (SPECIAL |$bootDefined| |$bootUsed| |$bootDefinedTwice|))
(RETURN
- (PROGN
- (|shoeFileLine| "DEFINED and not USED" |stream|)
- (SETQ |a|
- (LET ((|bfVar#2| NIL) (|bfVar#3| NIL)
- (|bfVar#1| (HKEYS |$bootDefined|)) (|i| NIL))
+ (PROGN
+ (|shoeFileLine| "DEFINED and not USED" |stream|)
+ (SETQ |a|
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| (HKEYS |$bootDefined|))
+ (|i| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN |bfVar#2|))
- (T (AND (NOT (|tableValue| |$bootUsed| |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|)))))
- (|bootOut| (SSORT |a|) |stream|)
- (|shoeFileLine| " " |stream|)
- (|shoeFileLine| "DEFINED TWICE" |stream|)
- (|bootOut| (SSORT |$bootDefinedTwice|) |stream|)
- (|shoeFileLine| " " |stream|)
- (|shoeFileLine| "USED and not DEFINED" |stream|)
- (SETQ |a|
- (LET ((|bfVar#5| NIL) (|bfVar#6| NIL)
- (|bfVar#4| (HKEYS |$bootUsed|)) (|i| NIL))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ (T
+ (AND (NOT (|tableValue| |$bootUsed| |i|))
+ (COND
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS |i| NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#)
+ (SETQ |bfVar#3| (CDR |bfVar#3|)))))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (|bootOut| (SSORT |a|) |stream|)
+ (|shoeFileLine| " " |stream|)
+ (|shoeFileLine| "DEFINED TWICE" |stream|)
+ (|bootOut| (SSORT |$bootDefinedTwice|) |stream|)
+ (|shoeFileLine| " " |stream|)
+ (|shoeFileLine| "USED and not DEFINED" |stream|)
+ (SETQ |a|
+ (LET ((|bfVar#5| NIL)
+ (|bfVar#6| NIL)
+ (|bfVar#4| (HKEYS |$bootUsed|))
+ (|i| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#4|))
- (PROGN (SETQ |i| (CAR |bfVar#4|)) NIL))
- (RETURN |bfVar#5|))
- (T (AND (NOT (|tableValue| |$bootDefined| |i|))
- (COND
- ((NULL |bfVar#5|)
- (SETQ |bfVar#5| #1=(CONS |i| NIL))
- (SETQ |bfVar#6| |bfVar#5|))
- (T (RPLACD |bfVar#6| #1#)
- (SETQ |bfVar#6| (CDR |bfVar#6|)))))))
- (SETQ |bfVar#4| (CDR |bfVar#4|)))))
- (LET ((|bfVar#7| (SSORT |a|)) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#7|))
- (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL))
- (RETURN NIL))
- (T (SETQ |b| (CONCAT (PNAME |i|) " is used in "))
- (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|))
- |stream| |b|)))
- (SETQ |bfVar#7| (CDR |bfVar#7|))))))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#4|))
+ (PROGN (SETQ |i| (CAR |bfVar#4|)) NIL))
+ (RETURN |bfVar#5|))
+ (T
+ (AND (NOT (|tableValue| |$bootDefined| |i|))
+ (COND
+ ((NULL |bfVar#5|) (SETQ |bfVar#5| #2=(CONS |i| NIL))
+ (SETQ |bfVar#6| |bfVar#5|))
+ (T (RPLACD |bfVar#6| #2#)
+ (SETQ |bfVar#6| (CDR |bfVar#6|)))))))
+ (SETQ |bfVar#4| (CDR |bfVar#4|)))))
+ (LET ((|bfVar#7| (SSORT |a|)) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#7|)) (PROGN (SETQ |i| (CAR |bfVar#7|)) NIL))
+ (RETURN NIL))
+ (T (SETQ |b| (CONCAT (PNAME |i|) " is used in "))
+ (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream|
+ |b|)))
+ (SETQ |bfVar#7| (CDR |bfVar#7|))))))))
(DEFUN |shoeDefUse| (|s|)
(LOOP
- (COND
- ((|bStreamPackageNull| |s|) (RETURN NIL))
- (T (|defuse| NIL (CAR |s|)) (SETQ |s| (CDR |s|))))))
+ (COND ((|bStreamPackageNull| |s|) (RETURN NIL))
+ (T (|defuse| NIL (CAR |s|)) (SETQ |s| (CDR |s|))))))
(DEFUN |defuse| (|e| |x|)
- (PROG (|niens| |nee| |LETTMP#1| |exp| |ISTMP#5| |id| |ISTMP#4|
- |ISTMP#3| |body| |bv| |ISTMP#2| |name| |ISTMP#1|)
- (DECLARE (SPECIAL |$bootUsed| |$bootDefinedTwice| |$bootDefined|
- |$used|))
+ (PROG (|niens| |nee| |LETTMP#1| |exp| |ISTMP#5| |id| |ISTMP#4| |ISTMP#3|
+ |body| |bv| |ISTMP#2| |name| |ISTMP#1|)
+ (DECLARE (SPECIAL |$used| |$bootDefined| |$bootDefinedTwice| |$bootUsed|))
(RETURN
- (PROGN
- (SETQ |x| (|stripm| |x| *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
- (SETQ |$used| NIL)
- (SETQ |LETTMP#1|
+ (PROGN
+ (SETQ |x| (|stripm| |x| *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
+ (SETQ |$used| NIL)
+ (SETQ |LETTMP#1|
(COND
- ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFUN)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |name| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (PROGN
- (SETQ |bv| (CAR |ISTMP#2|))
- (SETQ |body| (CDR |ISTMP#2|))
- T))))))
- (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|))))
- ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFMACRO)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |name| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (PROGN
- (SETQ |bv| (CAR |ISTMP#2|))
- (SETQ |body| (CDR |ISTMP#2|))
- T))))))
- (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|))))
- ((AND (CONSP |x|) (EQ (CAR |x|) 'EVAL-WHEN)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (NULL (CDR |ISTMP#2|))
- (PROGN
- (SETQ |ISTMP#3| (CAR |ISTMP#2|))
- (AND (CONSP |ISTMP#3|)
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFUN)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |name| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (PROGN
+ (SETQ |bv| (CAR |ISTMP#2|))
+ (SETQ |body| (CDR |ISTMP#2|))
+ T))))))
+ (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|))))
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'DEFMACRO)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |name| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (PROGN
+ (SETQ |bv| (CAR |ISTMP#2|))
+ (SETQ |body| (CDR |ISTMP#2|))
+ T))))))
+ (LIST |name| (CONS 'LAMBDA (CONS |bv| |body|))))
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'EVAL-WHEN)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN
+ (SETQ |ISTMP#3| (CAR |ISTMP#2|))
+ (AND (CONSP |ISTMP#3|)
(EQ (CAR |ISTMP#3|) 'SETQ)
(PROGN
- (SETQ |ISTMP#4|
- (CDR |ISTMP#3|))
- (AND (CONSP |ISTMP#4|)
- (PROGN
- (SETQ |id| (CAR |ISTMP#4|))
- (SETQ |ISTMP#5|
- (CDR |ISTMP#4|))
- (AND (CONSP |ISTMP#5|)
- (NULL (CDR |ISTMP#5|))
+ (SETQ |ISTMP#4| (CDR |ISTMP#3|))
+ (AND (CONSP |ISTMP#4|)
(PROGN
- (SETQ |exp|
- (CAR |ISTMP#5|))
- T))))))))))))
- (LIST |id| |exp|))
- ((AND (CONSP |x|) (EQ (CAR |x|) 'SETQ)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |id| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (NULL (CDR |ISTMP#2|))
- (PROGN
- (SETQ |exp| (CAR |ISTMP#2|))
- T))))))
- (LIST |id| |exp|))
- (T (LIST 'TOP-LEVEL |x|))))
- (SETQ |nee| (CAR |LETTMP#1|))
- (SETQ |niens| (CADR |LETTMP#1|))
- (COND
- ((|tableValue| |$bootDefined| |nee|)
- (SETQ |$bootDefinedTwice|
- (COND
- ((EQ |nee| 'TOP-LEVEL) |$bootDefinedTwice|)
- (T (CONS |nee| |$bootDefinedTwice|)))))
- (T (SETF (|tableValue| |$bootDefined| |nee|) T)))
- (|defuse1| |e| |niens|)
- (LET ((|bfVar#1| |$used|) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETF (|tableValue| |$bootUsed| |i|)
- (CONS |nee| (|tableValue| |$bootUsed| |i|)))))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
+ (SETQ |id| (CAR |ISTMP#4|))
+ (SETQ |ISTMP#5| (CDR |ISTMP#4|))
+ (AND (CONSP |ISTMP#5|)
+ (NULL (CDR |ISTMP#5|))
+ (PROGN
+ (SETQ |exp|
+ (CAR |ISTMP#5|))
+ T))))))))))))
+ (LIST |id| |exp|))
+ ((AND (CONSP |x|) (EQ (CAR |x|) 'SETQ)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |id| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |exp| (CAR |ISTMP#2|)) T))))))
+ (LIST |id| |exp|))
+ (T (LIST 'TOP-LEVEL |x|))))
+ (SETQ |nee| (CAR |LETTMP#1|))
+ (SETQ |niens| (CADR |LETTMP#1|))
+ (COND
+ ((|tableValue| |$bootDefined| |nee|)
+ (SETQ |$bootDefinedTwice|
+ (COND ((EQ |nee| 'TOP-LEVEL) |$bootDefinedTwice|)
+ (T (CONS |nee| |$bootDefinedTwice|)))))
+ (T (SETF (|tableValue| |$bootDefined| |nee|) T)))
+ (|defuse1| |e| |niens|)
+ (LET ((|bfVar#1| |$used|) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T
+ (SETF (|tableValue| |$bootUsed| |i|)
+ (CONS |nee| (|tableValue| |$bootUsed| |i|)))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
(DEFUN |defuse1| (|e| |y|)
(PROG (|ndol| |dol| |LETTMP#1| |b| |a| |ISTMP#1|)
- (DECLARE (SPECIAL |$bootDefined| |$used|))
+ (DECLARE (SPECIAL |$used| |$bootDefined|))
(RETURN
- (COND
- ((NOT (CONSP |y|))
- (COND
- ((SYMBOLP |y|)
- (SETQ |$used|
- (COND
- ((|symbolMember?| |y| |e|) |$used|)
- ((|symbolMember?| |y| |$used|) |$used|)
- ((|defusebuiltin| |y|) |$used|)
- (T (UNION (LIST |y|) |$used|)))))
- (T NIL)))
- ((AND (CONSP |y|) (EQ (CAR |y|) 'LAMBDA)
- (PROGN
- (SETQ |ISTMP#1| (CDR |y|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |a| (CAR |ISTMP#1|))
- (SETQ |b| (CDR |ISTMP#1|))
- T))))
- (|defuse1| (|append| (|unfluidlist| |a|) |e|) |b|))
- ((AND (CONSP |y|) (EQ (CAR |y|) 'PROG)
- (PROGN
- (SETQ |ISTMP#1| (CDR |y|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |a| (CAR |ISTMP#1|))
- (SETQ |b| (CDR |ISTMP#1|))
- T))))
- (SETQ |LETTMP#1| (|defSeparate| |a|))
- (SETQ |dol| (CAR |LETTMP#1|)) (SETQ |ndol| (CADR |LETTMP#1|))
- (LET ((|bfVar#1| |dol|) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETF (|tableValue| |$bootDefined| |i|) T)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))
- (|defuse1| (|append| |ndol| |e|) |b|))
- ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE)) (SETQ |a| (CDR |y|))
- NIL)
- ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE)) (SETQ |a| (CDR |y|))
- NIL)
- (T (LET ((|bfVar#2| |y|) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#2|))
- (PROGN (SETQ |i| (CAR |bfVar#2|)) NIL))
- (RETURN NIL))
- (T (|defuse1| |e| |i|)))
- (SETQ |bfVar#2| (CDR |bfVar#2|)))))))))
+ (COND
+ ((NOT (CONSP |y|))
+ (COND
+ ((SYMBOLP |y|)
+ (SETQ |$used|
+ (COND ((|symbolMember?| |y| |e|) |$used|)
+ ((|symbolMember?| |y| |$used|) |$used|)
+ ((|defusebuiltin| |y|) |$used|)
+ (T (UNION (LIST |y|) |$used|)))))
+ (T NIL)))
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'LAMBDA)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |y|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |a| (CAR |ISTMP#1|))
+ (SETQ |b| (CDR |ISTMP#1|))
+ T))))
+ (|defuse1| (|append| (|unfluidlist| |a|) |e|) |b|))
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'PROG)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |y|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |a| (CAR |ISTMP#1|))
+ (SETQ |b| (CDR |ISTMP#1|))
+ T))))
+ (SETQ |LETTMP#1| (|defSeparate| |a|)) (SETQ |dol| (CAR |LETTMP#1|))
+ (SETQ |ndol| (CADR |LETTMP#1|))
+ (LET ((|bfVar#1| |dol|) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETF (|tableValue| |$bootDefined| |i|) T)))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))
+ (|defuse1| (|append| |ndol| |e|) |b|))
+ ((AND (CONSP |y|) (EQ (CAR |y|) 'QUOTE)) (SETQ |a| (CDR |y|)) NIL)
+ ((AND (CONSP |y|) (EQ (CAR |y|) '+LINE)) (SETQ |a| (CDR |y|)) NIL)
+ (T
+ (LET ((|bfVar#2| |y|) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#2|)) (PROGN (SETQ |i| (CAR |bfVar#2|)) NIL))
+ (RETURN NIL))
+ (T (|defuse1| |e| |i|)))
+ (SETQ |bfVar#2| (CDR |bfVar#2|)))))))))
(DEFUN |defSeparate| (|x|)
(PROG (|x2| |x1| |LETTMP#1| |f|)
(RETURN
- (COND
- ((NULL |x|) (LIST NIL NIL))
- (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|))
- (T (LIST |x1| (CONS |f| |x2|)))))))))
+ (COND ((NULL |x|) (LIST NIL NIL))
+ (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|))
+ (T (LIST |x1| (CONS |f| |x2|)))))))))
(DEFUN |unfluidlist| (|x|)
(PROG (|y| |ISTMP#1|)
(RETURN
- (COND
- ((NULL |x|) NIL)
- ((NOT (CONSP |x|)) (LIST |x|))
- ((AND (CONSP |x|) (EQ (CAR |x|) '&REST)
- (PROGN
- (SETQ |ISTMP#1| (CDR |x|))
- (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
- (PROGN (SETQ |y| (CAR |ISTMP#1|)) T))))
- (LIST |y|))
- (T (CONS (CAR |x|) (|unfluidlist| (CDR |x|))))))))
+ (COND ((NULL |x|) NIL) ((NOT (CONSP |x|)) (LIST |x|))
+ ((AND (CONSP |x|) (EQ (CAR |x|) '&REST)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |x|))
+ (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))
+ (PROGN (SETQ |y| (CAR |ISTMP#1|)) T))))
+ (LIST |y|))
+ (T (CONS (CAR |x|) (|unfluidlist| (CDR |x|))))))))
(DEFUN |defusebuiltin| (|x|)
(DECLARE (SPECIAL |$lispWordTable|))
@@ -1073,12 +991,11 @@
(DEFUN |bootOut| (|l| |outfn|)
(LET ((|bfVar#1| |l|) (|i| NIL))
(LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (|shoeFileLine| (CONCAT " " (PNAME |i|)) |outfn|)))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (|shoeFileLine| (CONCAT " " (PNAME |i|)) |outfn|)))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
(DEFUN CLESSP (|s1| |s2|) (NOT (SHOEGREATERP |s1| |s2|)))
@@ -1087,131 +1004,122 @@
(DEFUN |bootOutLines| (|l| |outfn| |s|)
(PROG (|a|)
(RETURN
- (COND
- ((NULL |l|) (|shoeFileLine| |s| |outfn|))
- (T (SETQ |a| (PNAME (CAR |l|)))
- (COND
- ((< 70 (+ (LENGTH |s|) (LENGTH |a|)))
- (|shoeFileLine| |s| |outfn|)
+ (COND ((NULL |l|) (|shoeFileLine| |s| |outfn|))
+ (T (SETQ |a| (PNAME (CAR |l|)))
+ (COND
+ ((< 70 (+ (LENGTH |s|) (LENGTH |a|))) (|shoeFileLine| |s| |outfn|)
(|bootOutLines| |l| |outfn| " "))
(T (|bootOutLines| (CDR |l|) |outfn| (CONCAT |s| " " |a|)))))))))
(DEFUN XREF (|fn|)
(PROG (|a|)
(RETURN
- (UNWIND-PROTECT
- (PROGN
+ (UNWIND-PROTECT
+ (PROGN
(SETQ |a| (|inputTextFile| (CONCAT |fn| ".boot")))
(|shoeXref| |a| |fn|))
- (|closeStream| |a|)))))
+ (|closeStream| |a|)))))
(DEFUN |shoeXref| (|a| |fn|)
- (PROG (|$bfClamming| |$bootUsed| |$bootDefined| |$lispWordTable|
- |stream| |out|)
- (DECLARE (SPECIAL |$bfClamming| |$bootUsed| |$bootDefined|
- |$lispWordTable|))
+ (PROG (|$bfClamming| |$bootUsed| |$bootDefined| |$lispWordTable| |stream|
+ |out|)
+ (DECLARE
+ (SPECIAL |$bootDefined| |$bootUsed| |$bfClamming| |$lispWordTable|))
(RETURN
- (COND
- ((NULL |a|) (|shoeNotFound| |fn|))
- (T (SETQ |$lispWordTable| (|makeTable| #'EQ))
- (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP"))
- (SETF (|tableValue| |$lispWordTable| |i|) T))
- (SETQ |$bootDefined| (|makeTable| #'EQ))
- (SETQ |$bootUsed| (|makeTable| #'EQ))
- (SETQ |$bfClamming| NIL)
- (|shoeDefUse| (|shoeTransformStream| |a|))
- (SETQ |out| (CONCAT |fn| ".xref"))
- (UNWIND-PROTECT
- (PROGN
- (SETQ |stream| (|outputTextFile| |out|))
- (|shoeXReport| |stream|)
- |out|)
- (|closeStream| |stream|)))))))
+ (COND ((NULL |a|) (|shoeNotFound| |fn|))
+ (T (SETQ |$lispWordTable| (|makeTable| #'EQ))
+ (DO-SYMBOLS (|i| (FIND-PACKAGE "LISP"))
+ (SETF (|tableValue| |$lispWordTable| |i|) T))
+ (SETQ |$bootDefined| (|makeTable| #'EQ))
+ (SETQ |$bootUsed| (|makeTable| #'EQ)) (SETQ |$bfClamming| NIL)
+ (|shoeDefUse| (|shoeTransformStream| |a|))
+ (SETQ |out| (CONCAT |fn| ".xref"))
+ (UNWIND-PROTECT
+ (PROGN
+ (SETQ |stream| (|outputTextFile| |out|))
+ (|shoeXReport| |stream|)
+ |out|)
+ (|closeStream| |stream|)))))))
(DEFUN |shoeXReport| (|stream|)
(PROG (|a| |c|)
(DECLARE (SPECIAL |$bootUsed|))
(RETURN
- (PROGN
- (|shoeFileLine| "USED and where DEFINED" |stream|)
- (SETQ |c| (SSORT (HKEYS |$bootUsed|)))
- (LET ((|bfVar#1| |c|) (|i| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
- (RETURN NIL))
- (T (SETQ |a| (CONCAT (PNAME |i|) " is used in "))
- (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|))
- |stream| |a|)))
- (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
+ (PROGN
+ (|shoeFileLine| "USED and where DEFINED" |stream|)
+ (SETQ |c| (SSORT (HKEYS |$bootUsed|)))
+ (LET ((|bfVar#1| |c|) (|i| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|)) (PROGN (SETQ |i| (CAR |bfVar#1|)) NIL))
+ (RETURN NIL))
+ (T (SETQ |a| (CONCAT (PNAME |i|) " is used in "))
+ (|bootOutLines| (SSORT (|tableValue| |$bootUsed| |i|)) |stream|
+ |a|)))
+ (SETQ |bfVar#1| (CDR |bfVar#1|))))))))
(DEFUN |shoeItem| (|str|)
(PROG (|dq|)
(RETURN
- (PROGN
- (SETQ |dq| (CAR |str|))
- (CONS (LIST (LET ((|bfVar#2| NIL) (|bfVar#3| NIL)
- (|bfVar#1| (|shoeDQlines| |dq|))
- (|line| NIL))
- (LOOP
- (COND
- ((OR (NOT (CONSP |bfVar#1|))
- (PROGN
- (SETQ |line| (CAR |bfVar#1|))
- NIL))
- (RETURN |bfVar#2|))
- ((NULL |bfVar#2|)
- (SETQ |bfVar#2| #0=(CONS (CAR |line|) NIL))
- (SETQ |bfVar#3| |bfVar#2|))
- (T (RPLACD |bfVar#3| #0#)
- (SETQ |bfVar#3| (CDR |bfVar#3|))))
- (SETQ |bfVar#1| (CDR |bfVar#1|)))))
- (CDR |str|))))))
+ (PROGN
+ (SETQ |dq| (CAR |str|))
+ (CONS
+ (LIST
+ (LET ((|bfVar#2| NIL)
+ (|bfVar#3| NIL)
+ (|bfVar#1| (|shoeDQlines| |dq|))
+ (|line| NIL))
+ (LOOP
+ (COND
+ ((OR (NOT (CONSP |bfVar#1|))
+ (PROGN (SETQ |line| (CAR |bfVar#1|)) NIL))
+ (RETURN |bfVar#2|))
+ ((NULL |bfVar#2|) (SETQ |bfVar#2| #1=(CONS (CAR |line|) NIL))
+ (SETQ |bfVar#3| |bfVar#2|))
+ (T (RPLACD |bfVar#3| #1#) (SETQ |bfVar#3| (CDR |bfVar#3|))))
+ (SETQ |bfVar#1| (CDR |bfVar#1|)))))
+ (CDR |str|))))))
(DEFUN |stripm| (|x| |pk| |bt|)
(COND
- ((NOT (CONSP |x|))
- (COND
- ((SYMBOLP |x|)
- (COND
- ((EQUAL (SYMBOL-PACKAGE |x|) |bt|)
- (INTERN (SYMBOL-NAME |x|) |pk|))
- (T |x|)))
- (T |x|)))
- (T (CONS (|stripm| (CAR |x|) |pk| |bt|)
- (|stripm| (CDR |x|) |pk| |bt|)))))
+ ((NOT (CONSP |x|))
+ (COND
+ ((SYMBOLP |x|)
+ (COND ((EQUAL (SYMBOL-PACKAGE |x|) |bt|) (INTERN (SYMBOL-NAME |x|) |pk|))
+ (T |x|)))
+ (T |x|)))
+ (T (CONS (|stripm| (CAR |x|) |pk| |bt|) (|stripm| (CDR |x|) |pk| |bt|)))))
(DEFUN |shoePCompile| (|fn|)
(PROG (|body| |bv| |ISTMP#2| |name| |ISTMP#1|)
(RETURN
- (PROGN
- (SETQ |fn| (|stripm| |fn| *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
- (COND
- ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN)
- (PROGN
- (SETQ |ISTMP#1| (CDR |fn|))
- (AND (CONSP |ISTMP#1|)
- (PROGN
- (SETQ |name| (CAR |ISTMP#1|))
- (SETQ |ISTMP#2| (CDR |ISTMP#1|))
- (AND (CONSP |ISTMP#2|)
- (PROGN
- (SETQ |bv| (CAR |ISTMP#2|))
- (SETQ |body| (CDR |ISTMP#2|))
- T))))))
- (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|))))
- (T (EVAL |fn|)))))))
+ (PROGN
+ (SETQ |fn| (|stripm| |fn| *PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
+ (COND
+ ((AND (CONSP |fn|) (EQ (CAR |fn|) 'DEFUN)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |fn|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |name| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|)
+ (PROGN
+ (SETQ |bv| (CAR |ISTMP#2|))
+ (SETQ |body| (CDR |ISTMP#2|))
+ T))))))
+ (COMPILE |name| (CONS 'LAMBDA (CONS |bv| |body|))))
+ (T (EVAL |fn|)))))))
(DEFUN |shoePCompileTrees| (|s|)
(LOOP
- (COND
- ((|bStreamNull| |s|) (RETURN NIL))
- (T (REALLYPRETTYPRINT (|shoePCompile| (CAR |s|)))
- (SETQ |s| (CDR |s|))))))
+ (COND ((|bStreamNull| |s|) (RETURN NIL))
+ (T (REALLYPRETTYPRINT (|shoePCompile| (CAR |s|)))
+ (SETQ |s| (CDR |s|))))))
(DEFUN |bStreamPackageNull| (|s|)
- (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN"))) (|bStreamNull| |s|)))
+ (LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
+ (|bStreamNull| |s|)))
(DEFUN PSTTOMC (|string|)
(|shoePCompileTrees| (|shoeTransformString| |string|)))
@@ -1219,32 +1127,32 @@
(DEFUN BOOTLOOP ()
(PROG (|stream| |b| |a|)
(RETURN
- (PROGN
- (SETQ |a| (|readLine| *STANDARD-INPUT*))
+ (PROGN
+ (SETQ |a| (|readLine| *STANDARD-INPUT*))
+ (COND
+ ((EQL (LENGTH |a|) 0) (WRITE-LINE "Boot Loop; to exit type ] ")
+ (BOOTLOOP))
+ (T (SETQ |b| (|shoePrefix?| ")console" |a|))
(COND
- ((EQL (LENGTH |a|) 0)
- (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTLOOP))
- (T (SETQ |b| (|shoePrefix?| ")console" |a|))
- (COND
- (|b| (SETQ |stream| *TERMINAL-IO*)
- (PSTTOMC (|bRgen| |stream|)) (BOOTLOOP))
- ((CHAR= (SCHAR |a| 0) (|char| '])) NIL)
- (T (PSTTOMC (LIST |a|)) (BOOTLOOP)))))))))
+ (|b| (SETQ |stream| *TERMINAL-IO*) (PSTTOMC (|bRgen| |stream|))
+ (BOOTLOOP))
+ ((CHAR= (SCHAR |a| 0) (|char| '])) NIL)
+ (T (PSTTOMC (LIST |a|)) (BOOTLOOP)))))))))
(DEFUN BOOTPO ()
(PROG (|stream| |b| |a|)
(RETURN
- (PROGN
- (SETQ |a| (|readLine| *STANDARD-INPUT*))
+ (PROGN
+ (SETQ |a| (|readLine| *STANDARD-INPUT*))
+ (COND
+ ((EQL (LENGTH |a|) 0) (WRITE-LINE "Boot Loop; to exit type ] ")
+ (BOOTPO))
+ (T (SETQ |b| (|shoePrefix?| ")console" |a|))
(COND
- ((EQL (LENGTH |a|) 0)
- (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO))
- (T (SETQ |b| (|shoePrefix?| ")console" |a|))
- (COND
- (|b| (SETQ |stream| *TERMINAL-IO*)
- (PSTOUT (|bRgen| |stream|)) (BOOTPO))
- ((CHAR= (SCHAR |a| 0) (|char| '])) NIL)
- (T (PSTOUT (LIST |a|)) (BOOTPO)))))))))
+ (|b| (SETQ |stream| *TERMINAL-IO*) (PSTOUT (|bRgen| |stream|))
+ (BOOTPO))
+ ((CHAR= (SCHAR |a| 0) (|char| '])) NIL)
+ (T (PSTOUT (LIST |a|)) (BOOTPO)))))))))
(DEFUN PSTOUT (|string|)
(LET ((*PACKAGE* (FIND-PACKAGE "BOOTTRAN")))
@@ -1256,72 +1164,67 @@
(DEFUN |getIntermediateLispFile| (|file| |options|)
(PROG (|out|)
(RETURN
- (PROGN
- (SETQ |out| (NAMESTRING (|getOutputPathname| |options|)))
- (COND
- (|out| (CONCAT (|shoeRemoveStringIfNec|
- (CONCAT "." |$effectiveFaslType|) |out|)
- ".clisp"))
- (T (|defaultBootToLispFile| |file|)))))))
+ (PROGN
+ (SETQ |out| (NAMESTRING (|getOutputPathname| |options|)))
+ (COND
+ (|out|
+ (CONCAT
+ (|shoeRemoveStringIfNec| (CONCAT "." |$effectiveFaslType|) |out|)
+ ".clisp"))
+ (T (|defaultBootToLispFile| |file|)))))))
(DEFUN |translateBootFile| (|progname| |options| |file|)
(PROG (|outFile|)
(RETURN
- (PROGN
- (SETQ |outFile|
+ (PROGN
+ (SETQ |outFile|
(OR (|getOutputPathname| |options|)
(|defaultBootToLispFile| |file|)))
- (BOOTTOCL |file| (ENOUGH-NAMESTRING |outFile|))))))
+ (BOOTTOCL |file| (ENOUGH-NAMESTRING |outFile|))))))
(DEFUN |retainFile?| (|ext|)
(COND
- ((OR (MEMBER (|Option| '|all|) |$FilesToRetain|)
- (MEMBER (|Option| '|yes|) |$FilesToRetain|))
- T)
- ((MEMBER (|Option| '|no|) |$FilesToRetain|) NIL)
- (T (MEMBER (|Option| |ext|) |$FilesToRetain|))))
+ ((OR (MEMBER (|Option| '|all|) |$FilesToRetain|)
+ (MEMBER (|Option| '|yes|) |$FilesToRetain|))
+ T)
+ ((MEMBER (|Option| '|no|) |$FilesToRetain|) NIL)
+ (T (MEMBER (|Option| |ext|) |$FilesToRetain|))))
(DEFUN |compileBootHandler| (|progname| |options| |file|)
(PROG (|objFile| |intFile|)
(RETURN
- (PROGN
- (SETQ |intFile|
- (BOOTTOCL |file|
- (|getIntermediateLispFile| |file| |options|)))
- (COND
- ((NOT (EQL (|errorCount|) 0)) NIL)
- (|intFile|
- (SETQ |objFile|
- (|compileLispHandler| |progname| |options|
- |intFile|))
- (COND
- ((NOT (|retainFile?| '|lisp|)) (DELETE-FILE |intFile|)))
- |objFile|)
- (T NIL))))))
+ (PROGN
+ (SETQ |intFile|
+ (BOOTTOCL |file| (|getIntermediateLispFile| |file| |options|)))
+ (COND ((NOT (EQL (|errorCount|) 0)) NIL)
+ (|intFile|
+ (SETQ |objFile|
+ (|compileLispHandler| |progname| |options| |intFile|))
+ (COND ((NOT (|retainFile?| '|lisp|)) (DELETE-FILE |intFile|)))
+ |objFile|)
+ (T NIL))))))
(|associateRequestWithFileType| (|Option| "translate") "boot"
- #'|translateBootFile|)
+ #'|translateBootFile|)
(|associateRequestWithFileType| (|Option| "compile") "boot"
- #'|compileBootHandler|)
+ #'|compileBootHandler|)
(DEFUN |loadNativeModule| (|m|)
(COND
- ((|%hasFeature| :SBCL)
- (FUNCALL (|bfColonColon| 'SB-ALIEN 'LOAD-SHARED-OBJECT) |m|
- :DONT-SAVE T))
- ((|%hasFeature| :CLISP)
- (EVAL (LIST (|bfColonColon| 'FFI 'DEFAULT-FOREIGN-LIBRARY) |m|)))
- ((|%hasFeature| :ECL)
- (EVAL (LIST (|bfColonColon| 'FFI 'LOAD-FOREIGN-LIBRARY) |m|)))
- ((|%hasFeature| :CLOZURE)
- (EVAL (LIST (|bfColonColon| 'CCL 'OPEN-SHARED-LIBRARY) |m|)))
- (T (|coreError|
- "don't know how to load a dynamically linked module"))))
+ ((|%hasFeature| :SBCL)
+ (FUNCALL (|bfColonColon| 'SB-ALIEN 'LOAD-SHARED-OBJECT) |m| :DONT-SAVE T))
+ ((|%hasFeature| :CLISP)
+ (EVAL (LIST (|bfColonColon| 'FFI 'DEFAULT-FOREIGN-LIBRARY) |m|)))
+ ((|%hasFeature| :ECL)
+ (EVAL (LIST (|bfColonColon| 'FFI 'LOAD-FOREIGN-LIBRARY) |m|)))
+ ((|%hasFeature| :CLOZURE)
+ (EVAL (LIST (|bfColonColon| 'CCL 'OPEN-SHARED-LIBRARY) |m|)))
+ (T (|coreError| "don't know how to load a dynamically linked module"))))
(DEFUN |loadSystemRuntimeCore| ()
- (COND
- ((OR (|%hasFeature| :ECL) (|%hasFeature| :GCL)) NIL)
- (T (|loadNativeModule|
- (CONCAT "libopen-axiom-core" |$NativeModuleExt|)))))
+ (COND ((OR (|%hasFeature| :ECL) (|%hasFeature| :GCL)) NIL)
+ (T
+ (|loadNativeModule|
+ (CONCAT "libopen-axiom-core" |$NativeModuleExt|)))))
diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp
index f151c06e..4c2f649b 100644
--- a/src/boot/strap/utility.clisp
+++ b/src/boot/strap/utility.clisp
@@ -6,41 +6,38 @@
(PROVIDE "utility")
(EVAL-WHEN (:COMPILE-TOPLEVEL :LOAD-TOPLEVEL :EXECUTE)
- (EXPORT '(|objectMember?| |symbolMember?| |stringMember?|
- |charMember?| |scalarMember?| |listMember?| |reverse|
- |reverse!| |lastNode| |append| |append!| |copyList|
- |substitute| |substitute!| |setDifference| |applySubst|
- |applySubst!| |applySubstNQ| |remove| |removeSymbol|
- |atomic?| |finishLine|)))
+ (EXPORT
+ '(|objectMember?| |symbolMember?| |stringMember?| |charMember?|
+ |scalarMember?| |listMember?| |reverse| |reverse!|
+ |lastNode| |append| |append!| |copyList| |substitute|
+ |substitute!| |setDifference| |applySubst| |applySubst!|
+ |applySubstNQ| |remove| |removeSymbol| |atomic?|
+ |finishLine|)))
-(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|)
- |substitute|))
+(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|))
-(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|)
- |substitute!|))
+(DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute!|))
-(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|))
- (|%List| |%Thing|))
- |append|))
+(DECLAIM
+ (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
+ |append|))
-(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|))
- (|%List| |%Thing|))
- |append!|))
+(DECLAIM
+ (FTYPE (FUNCTION ((|%List| |%Thing|) (|%List| |%Thing|)) (|%List| |%Thing|))
+ |append!|))
-(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|)) (|%List| |%Thing|))
- |copyList|))
+(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|)) (|%List| |%Thing|)) |copyList|))
-(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|))
- (|%Maybe| (|%Node| |%Thing|)))
- |lastNode|))
+(DECLAIM
+ (FTYPE (FUNCTION ((|%List| |%Thing|)) (|%Maybe| (|%Node| |%Thing|)))
+ |lastNode|))
-(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|) |%Symbol|)
- (|%List| |%Thing|))
- |removeSymbol|))
+(DECLAIM
+ (FTYPE (FUNCTION ((|%List| |%Thing|) |%Symbol|) (|%List| |%Thing|))
+ |removeSymbol|))
-(DECLAIM (FTYPE (FUNCTION ((|%List| |%Thing|) |%Thing|)
- (|%List| |%Thing|))
- |remove|))
+(DECLAIM
+ (FTYPE (FUNCTION ((|%List| |%Thing|) |%Thing|) (|%List| |%Thing|)) |remove|))
(DECLAIM (FTYPE (FUNCTION (|%Thing|) |%Boolean|) |atomic?|))
@@ -50,276 +47,232 @@
(DEFUN |objectMember?| (|x| |l|)
(LOOP
- (COND
- ((NULL |l|) (RETURN NIL))
- ((CONSP |l|)
- (COND ((EQ |x| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
- (T (RETURN (EQ |x| |l|))))))
+ (COND ((NULL |l|) (RETURN NIL))
+ ((CONSP |l|)
+ (COND ((EQ |x| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
+ (T (RETURN (EQ |x| |l|))))))
(DEFUN |symbolMember?| (|s| |l|)
(LOOP
- (COND
- ((NULL |l|) (RETURN NIL))
- ((CONSP |l|)
- (COND ((EQ |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
- (T (RETURN (EQ |s| |l|))))))
+ (COND ((NULL |l|) (RETURN NIL))
+ ((CONSP |l|)
+ (COND ((EQ |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
+ (T (RETURN (EQ |s| |l|))))))
(DEFUN |stringMember?| (|s| |l|)
(LOOP
- (COND
- ((NULL |l|) (RETURN NIL))
- ((CONSP |l|)
- (COND
- ((STRING= |s| (CAR |l|)) (RETURN T))
- (T (SETQ |l| (CDR |l|)))))
- (T (RETURN (STRING= |s| |l|))))))
+ (COND ((NULL |l|) (RETURN NIL))
+ ((CONSP |l|)
+ (COND ((STRING= |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
+ (T (RETURN (STRING= |s| |l|))))))
(DEFUN |charMember?| (|c| |l|)
(LOOP
- (COND
- ((NULL |l|) (RETURN NIL))
- ((CONSP |l|)
- (COND
- ((CHAR= |c| (CAR |l|)) (RETURN T))
- (T (SETQ |l| (CDR |l|)))))
- (T (RETURN (CHAR= |c| |l|))))))
+ (COND ((NULL |l|) (RETURN NIL))
+ ((CONSP |l|)
+ (COND ((CHAR= |c| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
+ (T (RETURN (CHAR= |c| |l|))))))
(DEFUN |scalarMember?| (|s| |l|)
(LOOP
- (COND
- ((NULL |l|) (RETURN NIL))
- ((CONSP |l|)
- (COND
- ((EQL |s| (CAR |l|)) (RETURN T))
- (T (SETQ |l| (CDR |l|)))))
- (T (RETURN (EQL |s| |l|))))))
+ (COND ((NULL |l|) (RETURN NIL))
+ ((CONSP |l|)
+ (COND ((EQL |s| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
+ (T (RETURN (EQL |s| |l|))))))
(DEFUN |listMember?| (|x| |l|)
(LOOP
- (COND
- ((NULL |l|) (RETURN NIL))
- ((CONSP |l|)
- (COND
- ((EQUAL |x| (CAR |l|)) (RETURN T))
- (T (SETQ |l| (CDR |l|)))))
- (T (RETURN (EQUAL |x| |l|))))))
+ (COND ((NULL |l|) (RETURN NIL))
+ ((CONSP |l|)
+ (COND ((EQUAL |x| (CAR |l|)) (RETURN T)) (T (SETQ |l| (CDR |l|)))))
+ (T (RETURN (EQUAL |x| |l|))))))
(DEFUN |reverse| (|l|)
(PROG (|r|)
(RETURN
- (PROGN
- (SETQ |r| NIL)
- (LOOP
- (COND
- ((CONSP |l|) (SETQ |r| (CONS (CAR |l|) |r|))
- (SETQ |l| (CDR |l|)))
- (T (RETURN |r|))))))))
+ (PROGN
+ (SETQ |r| NIL)
+ (LOOP
+ (COND ((CONSP |l|) (SETQ |r| (CONS (CAR |l|) |r|)) (SETQ |l| (CDR |l|)))
+ (T (RETURN |r|))))))))
(DEFUN |reverse!| (|l|)
(PROG (|l2| |l1|)
(RETURN
- (PROGN
- (SETQ |l1| NIL)
- (LOOP
- (COND
- ((CONSP |l|) (SETQ |l2| (CDR |l|)) (RPLACD |l| |l1|)
- (SETQ |l1| |l|) (SETQ |l| |l2|))
- (T (RETURN |l1|))))))))
+ (PROGN
+ (SETQ |l1| NIL)
+ (LOOP
+ (COND
+ ((CONSP |l|) (SETQ |l2| (CDR |l|)) (RPLACD |l| |l1|) (SETQ |l1| |l|)
+ (SETQ |l| |l2|))
+ (T (RETURN |l1|))))))))
(DEFUN |lastNode| (|l|)
(PROG (|l'|)
(RETURN
- (PROGN
- (LOOP
- (COND
- ((NOT (AND (CONSP |l|) (PROGN (SETQ |l'| (CDR |l|)) T)
- (CONSP |l'|)))
- (RETURN NIL))
- (T (SETQ |l| |l'|))))
- |l|))))
+ (PROGN
+ (LOOP
+ (COND
+ ((NOT (AND (CONSP |l|) (PROGN (SETQ |l'| (CDR |l|)) T) (CONSP |l'|)))
+ (RETURN NIL))
+ (T (SETQ |l| |l'|))))
+ |l|))))
(DEFUN |copyList| (|l|)
(PROG (|l'| |t|)
(RETURN
- (COND
- ((NOT (CONSP |l|)) |l|)
- (T (SETQ |l'| (SETQ |t| (LIST (CAR |l|))))
- (LOOP
+ (COND ((NOT (CONSP |l|)) |l|)
+ (T (SETQ |l'| (SETQ |t| (LIST (CAR |l|))))
+ (LOOP
(PROGN
- (SETQ |l| (CDR |l|))
- (COND
- ((CONSP |l|) (RPLACD |t| (LIST (CAR |l|)))
- (SETQ |t| (CDR |t|)))
- (T (RPLACD |t| |l|) (RETURN |l'|))))))))))
+ (SETQ |l| (CDR |l|))
+ (COND
+ ((CONSP |l|) (RPLACD |t| (LIST (CAR |l|))) (SETQ |t| (CDR |t|)))
+ (T (RPLACD |t| |l|) (RETURN |l'|))))))))))
(DEFUN |append!| (|x| |y|)
- (COND
- ((NULL |x|) |y|)
- ((NULL |y|) |x|)
- (T (RPLACD (|lastNode| |x|) |y|) |x|)))
+ (COND ((NULL |x|) |y|) ((NULL |y|) |x|)
+ (T (RPLACD (|lastNode| |x|) |y|) |x|)))
(DEFUN |append| (|x| |y|) (|append!| (|copyList| |x|) |y|))
(DEFUN |assocSymbol| (|s| |al|)
(PROG (|x|)
(RETURN
- (LOOP
- (COND
- ((AND (CONSP |al|)
- (PROGN (SETQ |x| (CAR |al|)) (SETQ |al| (CDR |al|)) T))
- (COND
- ((AND (CONSP |x|) (EQ |s| (CAR |x|)))
- (IDENTITY (RETURN |x|)))))
- (T (RETURN NIL)))))))
+ (LOOP
+ (COND
+ ((AND (CONSP |al|)
+ (PROGN (SETQ |x| (CAR |al|)) (SETQ |al| (CDR |al|)) T))
+ (COND ((AND (CONSP |x|) (EQ |s| (CAR |x|))) (IDENTITY (RETURN |x|)))))
+ (T (RETURN NIL)))))))
(DEFUN |substitute!| (|y| |x| |s|)
- (COND
- ((NULL |s|) NIL)
- ((EQ |x| |s|) |y|)
- (T (COND
- ((CONSP |s|) (RPLACA |s| (|substitute!| |y| |x| (CAR |s|)))
- (RPLACD |s| (|substitute!| |y| |x| (CDR |s|)))))
- |s|)))
+ (COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|)
+ (T
+ (COND
+ ((CONSP |s|) (RPLACA |s| (|substitute!| |y| |x| (CAR |s|)))
+ (RPLACD |s| (|substitute!| |y| |x| (CDR |s|)))))
+ |s|)))
(DEFUN |substitute| (|y| |x| |s|)
(PROG (|t| |h|)
(RETURN
- (COND
- ((NULL |s|) NIL)
- ((EQ |x| |s|) |y|)
- ((CONSP |s|) (SETQ |h| (|substitute| |y| |x| (CAR |s|)))
- (SETQ |t| (|substitute| |y| |x| (CDR |s|)))
- (COND
- ((AND (EQ |h| (CAR |s|)) (EQ |t| (CDR |s|))) |s|)
- (T (CONS |h| |t|))))
- (T |s|)))))
+ (COND ((NULL |s|) NIL) ((EQ |x| |s|) |y|)
+ ((CONSP |s|) (SETQ |h| (|substitute| |y| |x| (CAR |s|)))
+ (SETQ |t| (|substitute| |y| |x| (CDR |s|)))
+ (COND ((AND (EQ |h| (CAR |s|)) (EQ |t| (CDR |s|))) |s|)
+ (T (CONS |h| |t|))))
+ (T |s|)))))
(DEFUN |applySubst| (|sl| |t|)
(PROG (|p| |tl| |hd|)
(RETURN
- (COND
- ((CONSP |t|) (SETQ |hd| (|applySubst| |sl| (CAR |t|)))
- (SETQ |tl| (|applySubst| |sl| (CDR |t|)))
- (COND
- ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|)
- (T (CONS |hd| |tl|))))
- ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|)))
- (CDR |p|))
- (T |t|)))))
+ (COND
+ ((CONSP |t|) (SETQ |hd| (|applySubst| |sl| (CAR |t|)))
+ (SETQ |tl| (|applySubst| |sl| (CDR |t|)))
+ (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|)
+ (T (CONS |hd| |tl|))))
+ ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) (CDR |p|))
+ (T |t|)))))
(DEFUN |applySubst!| (|sl| |t|)
(PROG (|p| |tl| |hd|)
(RETURN
- (COND
- ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|)))
- (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|)
- (RPLACD |t| |tl|))
- ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|)))
- (CDR |p|))
- (T |t|)))))
+ (COND
+ ((CONSP |t|) (SETQ |hd| (|applySubst!| |sl| (CAR |t|)))
+ (SETQ |tl| (|applySubst!| |sl| (CDR |t|))) (RPLACA |t| |hd|)
+ (RPLACD |t| |tl|))
+ ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) (CDR |p|))
+ (T |t|)))))
(DEFUN |applySubstNQ| (|sl| |t|)
(PROG (|p| |tl| |hd|)
(RETURN
- (COND
- ((AND (CONSP |t|)
- (PROGN (SETQ |hd| (CAR |t|)) (SETQ |tl| (CDR |t|)) T))
- (COND
- ((EQ |hd| 'QUOTE) |t|)
- (T (SETQ |hd| (|applySubstNQ| |sl| |hd|))
+ (COND
+ ((AND (CONSP |t|) (PROGN (SETQ |hd| (CAR |t|)) (SETQ |tl| (CDR |t|)) T))
+ (COND ((EQ |hd| 'QUOTE) |t|)
+ (T (SETQ |hd| (|applySubstNQ| |sl| |hd|))
(SETQ |tl| (|applySubstNQ| |sl| |tl|))
- (COND
- ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|)
- (T (CONS |hd| |tl|))))))
- ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|)))
- (CDR |p|))
- (T |t|)))))
+ (COND ((AND (EQ |hd| (CAR |t|)) (EQ |tl| (CDR |t|))) |t|)
+ (T (CONS |hd| |tl|))))))
+ ((AND (SYMBOLP |t|) (SETQ |p| (|assocSymbol| |t| |sl|))) (CDR |p|))
+ (T |t|)))))
(DEFUN |setDifference| (|x| |y|)
(PROG (|a| |l| |p|)
(RETURN
- (COND
- ((NULL |x|) NIL)
- ((NULL |y|) |x|)
- (T (SETQ |l| (SETQ |p| (LIST NIL)))
- (LET ((|bfVar#1| |x|))
- (LOOP
- (COND
- ((NOT (CONSP |bfVar#1|)) (RETURN NIL))
- (T (AND (CONSP |bfVar#1|)
- (PROGN (SETQ |a| (CAR |bfVar#1|)) T)
- (NOT (|objectMember?| |a| |y|))
- (PROGN
- (RPLACD |p| (LIST |a|))
- (SETQ |p| (CDR |p|))))))
+ (COND ((NULL |x|) NIL) ((NULL |y|) |x|)
+ (T (SETQ |l| (SETQ |p| (LIST NIL)))
+ (LET ((|bfVar#1| |x|))
+ (LOOP
+ (COND ((NOT (CONSP |bfVar#1|)) (RETURN NIL))
+ (T
+ (AND (CONSP |bfVar#1|)
+ (PROGN (SETQ |a| (CAR |bfVar#1|)) T)
+ (NOT (|objectMember?| |a| |y|))
+ (PROGN
+ (RPLACD |p| (LIST |a|))
+ (SETQ |p| (CDR |p|))))))
(SETQ |bfVar#1| (CDR |bfVar#1|))))
- (CDR |l|))))))
+ (CDR |l|))))))
(DEFUN |removeSymbol| (|l| |x|)
(PROG (|y| |LETTMP#1| |l'| |before|)
(RETURN
- (PROGN
- (SETQ |before| NIL)
- (SETQ |l'| |l|)
- (LOOP
- (COND
- ((NOT (CONSP |l'|)) (RETURN |l|))
- (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
- (SETQ |l'| (CDR |LETTMP#1|))
- (COND
- ((EQ |x| |y|)
- (RETURN (|append!| (|reverse!| |before|) |l'|)))
- (T (SETQ |before| (CONS |y| |before|)))))))))))
+ (PROGN
+ (SETQ |before| NIL)
+ (SETQ |l'| |l|)
+ (LOOP
+ (COND ((NOT (CONSP |l'|)) (RETURN |l|))
+ (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
+ (SETQ |l'| (CDR |LETTMP#1|))
+ (COND
+ ((EQ |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|)))
+ (T (SETQ |before| (CONS |y| |before|)))))))))))
(DEFUN |removeScalar| (|l| |x|)
(PROG (|y| |LETTMP#1| |l'| |before|)
(RETURN
- (PROGN
- (SETQ |before| NIL)
- (SETQ |l'| |l|)
- (LOOP
- (COND
- ((NOT (CONSP |l'|)) (RETURN |l|))
- (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
- (SETQ |l'| (CDR |LETTMP#1|))
- (COND
- ((EQL |x| |y|)
- (RETURN (|append!| (|reverse!| |before|) |l'|)))
- (T (SETQ |before| (CONS |y| |before|)))))))))))
+ (PROGN
+ (SETQ |before| NIL)
+ (SETQ |l'| |l|)
+ (LOOP
+ (COND ((NOT (CONSP |l'|)) (RETURN |l|))
+ (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
+ (SETQ |l'| (CDR |LETTMP#1|))
+ (COND
+ ((EQL |x| |y|) (RETURN (|append!| (|reverse!| |before|) |l'|)))
+ (T (SETQ |before| (CONS |y| |before|)))))))))))
(DEFUN |removeValue| (|l| |x|)
(PROG (|y| |LETTMP#1| |l'| |before|)
(RETURN
- (PROGN
- (SETQ |before| NIL)
- (SETQ |l'| |l|)
- (LOOP
- (COND
- ((NOT (CONSP |l'|)) (RETURN |l|))
- (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
- (SETQ |l'| (CDR |LETTMP#1|))
- (COND
- ((EQUAL |x| |y|)
- (RETURN (|append!| (|reverse!| |before|) |l'|)))
- (T (SETQ |before| (CONS |y| |before|)))))))))))
+ (PROGN
+ (SETQ |before| NIL)
+ (SETQ |l'| |l|)
+ (LOOP
+ (COND ((NOT (CONSP |l'|)) (RETURN |l|))
+ (T (SETQ |LETTMP#1| |l'|) (SETQ |y| (CAR |LETTMP#1|))
+ (SETQ |l'| (CDR |LETTMP#1|))
+ (COND
+ ((EQUAL |x| |y|)
+ (RETURN (|append!| (|reverse!| |before|) |l'|)))
+ (T (SETQ |before| (CONS |y| |before|)))))))))))
(DEFUN |remove| (|l| |x|)
- (COND
- ((SYMBOLP |x|) (|removeSymbol| |l| |x|))
- ((OR (CHARACTERP |x|) (INTEGERP |x|)) (|removeScalar| |l| |x|))
- (T (|removeValue| |l| |x|))))
+ (COND ((SYMBOLP |x|) (|removeSymbol| |l| |x|))
+ ((OR (CHARACTERP |x|) (INTEGERP |x|)) (|removeScalar| |l| |x|))
+ (T (|removeValue| |l| |x|))))
(DEFUN |charPosition| (|c| |s| |k|)
(PROG (|n|)
(RETURN
- (PROGN
- (SETQ |n| (LENGTH |s|))
- (LOOP
- (COND
- ((NOT (< |k| |n|)) (RETURN NIL))
- ((CHAR= (SCHAR |s| |k|) |c|) (RETURN |k|))
- (T (SETQ |k| (+ |k| 1)))))))))
-
-(DEFUN |finishLine| (|out|)
- (PROGN (TERPRI |out|) (FORCE-OUTPUT |out|)))
+ (PROGN
+ (SETQ |n| (LENGTH |s|))
+ (LOOP
+ (COND ((NOT (< |k| |n|)) (RETURN NIL))
+ ((CHAR= (SCHAR |s| |k|) |c|) (RETURN |k|))
+ (T (SETQ |k| (+ |k| 1)))))))))
+
+(DEFUN |finishLine| (|out|) (PROGN (TERPRI |out|) (FORCE-OUTPUT |out|)))