From a27cc2ac7bf6a0ad60cc6c9f949a988d0444bb4e Mon Sep 17 00:00:00 2001 From: dos-reis Date: Mon, 28 Jan 2008 04:16:25 +0000 Subject: * boot/Makefile.pamphlet: Remove. * boot/translator.boot: New. * boot/translator.boot: Remove. * boot/tokens.boot: New. * boot/tokens.boot.pamphlet: Remove. * boot/scanner.boot: New. * boot/scanner.boot.pamphlet: Remove. * boot/pile.boot: New. * boot/pile.boot.pamphlet: Remove. * boot/parser.boot: New. * boot/parser.boot.pamphlet: New. * boot/initial-env.lisp: New. * boot/initial-env.lisp.pamphlet: Remove. * boot/includer.boot: New. * boot/includer.boot.pamphlet: Remove. * boot/ast.boot: New. * boot/ast.boot.pamphlet: Remove. --- src/boot/ast.boot.pamphlet | 3195 -------------------------------------------- 1 file changed, 3195 deletions(-) delete mode 100644 src/boot/ast.boot.pamphlet (limited to 'src/boot/ast.boot.pamphlet') diff --git a/src/boot/ast.boot.pamphlet b/src/boot/ast.boot.pamphlet deleted file mode 100644 index b0c2f483..00000000 --- a/src/boot/ast.boot.pamphlet +++ /dev/null @@ -1,3195 +0,0 @@ -\documentclass{article} -\usepackage{axiom} - -\title{\File{src/boot/ast.boot} Pamphlet} -\author{The Axiom Team} - -\begin{document} -\maketitle -\begin{abstract} -\end{abstract} - -\tableofcontents -\eject - -Note that shoeReadLispString has a duplicate definition in this file. -I don't know why. I've commented out the first definition since it -gets overwritten. - -\section{License} - -<>= --- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are --- met: --- --- - Redistributions of source code must retain the above copyright --- notice, this list of conditions and the following disclaimer. --- --- - Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in --- the documentation and/or other materials provided with the --- distribution. --- --- - Neither the name of The Numerical ALgorithms Group Ltd. nor the --- names of its contributors may be used to endorse or promote products --- derived from this software without specific prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS --- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED --- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A --- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER --- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, --- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, --- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR --- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF --- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING --- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS --- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -@ - -\section{Abstract syntax tree} - -<>= -++ A Boot string is no different from a Lisp string. Same holds -++ for symbols and sequences. In an ideal world, these would be -++ built-in/library data types. -String <=> STRING -Symbol <=> SYMBOL -Sequence <=> SEQUENCE - -++ Ideally, we would like to say that a List T if either nil or a -++ cons of a T and List of T. However, we don't support parameterized -++ alias definitions yet. -List <=> nil or cons - -++ Currently, the Boot processor uses Lisp symbol datatype for names. -++ That causes the BOOTTRAN package to contain more symbols than we would -++ like. In the future, we want want to intern `on demand'. How that -++ interacts with renaming is to be worked out. -structure Name == Name(Symbol) - -structure Ast == - Command(String) -- includer command - Module(String) -- module declaration - Import(String) -- import module - ImportSignature(Name, Signature) -- import function declaration - TypeAlias(Name, List, List) -- type alias definition - Signature(Name, Mapping) -- op: S -> T - Mapping(Ast, List) -- (S1, S2) -> T - SuffixDot(Ast) -- x . - Quote(Ast) -- 'x - EqualName(Name) -- =x -- patterns - Colon(Name) -- :x - QualifiedName(Name, Name) -- m::x - Bracket(Ast) -- [x, y] - UnboundedSegment(Ast) -- 3.. - BoundedSgement(Ast, Ast) -- 2..4 - Tuple(List) -- comma-separated expression sequence - ColonAppend(Ast, Ast) -- [:y] or [x, :y] - Is(Ast, Ast) -- e is p -- patterns - Isnt(Ast, Ast) -- e isnt p -- patterns - Reduce(Ast, Ast) -- +/[...] - PrefixExpr(Name, Ast) -- #v - Call(Ast, Sequence) -- f(x, y , z) - InfixExpr(Name, Ast, Ast) -- x + y - ConstantDefinition(Name, Ast) -- x == y - Definition(Name, List, Ast, Ast) -- f x == y - Macro(Name, List, Ast) -- m x ==> y - SuchThat(Ast) -- | p - Assignment(Ast, Ast) -- x := y - While(Ast) -- while p -- iterator - Until(Ast) -- until p -- iterator - For(Ast, Ast, Ast) -- for x in e by k -- iterator - Exit(Ast, Ast) -- p => x - Iterators(List) -- list of iterators - Cross(List) -- iterator cross product - Repeat(Sequence, Ast) -- while p repeat s - Pile(Sequence) -- pile of expression sequence - Append(Sequence) -- concatenate lists - Case(Ast, Sequence) -- case x of ... - Return(Ast) -- return x - Where(Ast, Sequence) -- e where f x == y - Structure(Ast, Sequence) -- structure Foo == ... -@ - - -\section{Putting it all together} -<<*>>= -<> - -module '"boot-ast" -import '"includer" - -)package "BOOTTRAN" - -++ True means that Boot functions should be translated to use -++ hash tables to remember values. By default, functions are -++ translated with the obvious semantics, e.g. no caching. -$bfClamming := false - -<> - --- TRUE if we are currently building the syntax tree for an 'is' --- expression. -$inDefIS := false - -bfGenSymbol()== - $GenVarCounter:=$GenVarCounter+1 - INTERN(CONCAT ('"bfVar#",STRINGIMAGE $GenVarCounter)) - -bfListOf x==x - -bfColon x== ["COLON",x] - -bfColonColon(package, name) == - INTERN(SYMBOL_-NAME name, package) - -bfSymbol x== - STRINGP x=> x - ['QUOTE,x] - -bfDot()== "DOT" - -bfSuffixDot x==[x,"DOT"] - -bfEqual(name)== ["EQUAL",name] - -bfBracket(part) == part - -bfPile(part) == part - -bfAppend x== APPLY(function APPEND,x) - -bfColonAppend (x,y) == - if null x - then - if y is ["BVQUOTE",:a] - then ["&REST",["QUOTE",:a]] - else ["&REST",y] - else cons(CAR x,bfColonAppend(CDR x,y)) - -bfDefinition(bflhsitems, bfrhs,body) == - ['DEF,bflhsitems,bfrhs,body] - -bfMDefinition(bflhsitems, bfrhs,body) == - bfMDef('MDEF,bflhsitems,bfrhs,body) - -bfCompDef x == - case x of - ConstantDefinition(n, e) => x - otherwise => - x is [def, op, args, body] => - bfDef(def,op,args,body) - coreError '"invalid AST" - -bfBeginsDollar x== EQL('"$".0,(PNAME x).0) - -compFluid id== ["FLUID",id] - -compFluidize x== - IDENTP x and bfBeginsDollar x=>compFluid x - ATOM x =>x - EQCAR(x,"QUOTE")=>x - cons(compFluidize(CAR x),compFluidize(CDR x)) - -bfTuple x== ["TUPLE",:x] - -bfTupleP x==EQCAR(x,"TUPLE") - -bfTupleIf x== - if bfTupleP x - then x - else bfTuple x - -bfTupleConstruct b == - a:= if bfTupleP b - then cdr b - else [b] - or/[x is ["COLON",.] for x in a] => bfMakeCons a - ["LIST",:a] - -bfConstruct b == - a:= if bfTupleP b - then cdr b - else [b] - bfMakeCons a - -bfMakeCons l == - null l => NIL - l is [["COLON",a],:l1] => - l1 => ['APPEND,a,bfMakeCons l1] - a - ['CONS,first l,bfMakeCons rest l] - -bfFor(bflhs,U,step) == - if EQCAR (U,'tails) - then bfForTree('ON, bflhs, CADR U) - else - if EQCAR(U,"SEGMENT") - then bfSTEP(bflhs,CADR U,step,CADDR U) - else bfForTree('IN, bflhs, U) - -bfForTree(OP,lhs,whole)== - whole:=if bfTupleP whole then bfMakeCons cdr whole else whole - ATOM lhs =>bfINON [OP,lhs,whole] - lhs:=if bfTupleP lhs then CADR lhs else lhs - EQCAR(lhs,"L%T") => - G:=CADR lhs - [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,CADDR lhs)] - G:=bfGenSymbol() - [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,lhs)] - - -bfSTEP(id,fst,step,lst)== - initvar:=[id] - initval:=[fst] - inc:=if ATOM step - then step - else - g1:=bfGenSymbol() - initvar:=cons(g1,initvar) - initval:=cons(step,initval) - g1 - final:=if ATOM lst - then lst - else - g2:=bfGenSymbol() - initvar:=cons(g2,initvar) - initval:=cons(lst,initval) - g2 - ex:= - null lst=> [] - INTEGERP inc => - pred:=if MINUSP inc then "<" else ">" - [[pred,id,final]] - [['COND,[['MINUSP,inc], - ["<",id,final]],['T,[">",id,final]]]] - suc:=[['SETQ,id,["+",id,inc]]] - [[initvar,initval,suc,[],ex,[]]] - - -bfINON x== - [op,id,whole]:=x - if EQ(op,"ON") - then bfON(id,whole) - else bfIN(id,whole) - -bfIN(x,E)== - g:=bfGenSymbol() - [[[g,x],[E,nil],[['SETQ,g,['CDR, g]]],[], - [['OR,['ATOM,g],['PROGN,['SETQ,x,['CAR,g]] ,'NIL]]],[]]] - -bfON(x,E)== - [[[x],[E],[['SETQ,x,['CDR, x]]],[], - [['ATOM,x]],[]]] - -bfSuchthat p== [[[],[],[],[p],[],[]]] - -bfWhile p== [[[],[],[],[],[bfNOT p],[]]] - -bfUntil p== - g:=bfGenSymbol() - [[[g],[nil],[['SETQ,g,p]],[],[g],[]]] - -bfIterators x==["ITERATORS",:x] - -bfCross x== ["CROSS",:x] - -bfLp(iters,body)== - EQCAR (iters,"ITERATORS")=>bfLp1(CDR iters,body) - bfLpCross(CDR iters,body) - -bfLpCross(iters,body)== - if null cdr iters - then bfLp(car iters,body) - else bfLp(car iters,bfLpCross(cdr iters,body)) - -bfSep(iters)== - if null iters - then [[],[],[],[],[],[]] - else - f:=first iters - r:=bfSep rest iters - [append(i,j) for i in f for j in r] - -bfReduce(op,y)== - a:=if EQCAR(op,"QUOTE") then CADR op else op - op:=bfReName a - init:=GET(op,"SHOETHETA") - g:=bfGenSymbol() - g1:=bfGenSymbol() - body:=['SETQ,g,[op,g,g1]] - if null init - then - g2:=bfGenSymbol() - init:=['CAR,g2] - ny:=['CDR,g2] - it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,ny)]] - bfMKPROGN [['L%T,g2,y],bfLp(it,body)] - else - init:=car init - it:= ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,y)]] - bfLp(it,body) - -bfReduceCollect(op,y)== - if EQCAR (y,"COLLECT") - then - body:=y.1 - itl:=y.2 - a:=if EQCAR(op,"QUOTE") then CADR op else op - op:=bfReName a - init:=GET(op,"SHOETHETA") - bfOpReduce(op,init,body,itl) - else - a:=bfTupleConstruct (y.1) - bfReduce(op,a) - --- delayed collect - -bfDCollect(y,itl)== ["COLLECT",y,itl] - -bfDTuple x== ["DTUPLE",x] - -bfCollect(y,itl) == - y is ["COLON",a] => bf0APPEND(a,itl) - y is ["TUPLE",:.] => - newBody:=bfConstruct y - bf0APPEND(newBody,itl) - bf0COLLECT(y,itl) - -bf0COLLECT(y,itl)==bfListReduce('CONS,y,itl) - - -bf0APPEND(y,itl)== - g:=bfGenSymbol() - body:=['SETQ,g,['APPEND,['REVERSE,y],g]] - extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]] - bfLp2(extrait,itl,body) - -bfListReduce(op,y,itl)== - g:=bfGenSymbol() - body:=['SETQ,g,[op,y,g]] - extrait:= [[[g],[nil],[],[],[],[['NREVERSE,g]]]] - bfLp2(extrait,itl,body) - -bfLp1(iters,body)== - [vars,inits,sucs,filters,exits,value]:=bfSep bfAppend iters - nbody:=if null filters then body else bfAND [:filters,body] - value:=if null value then "NIL" else car value - exits:= ["COND",[bfOR exits,["RETURN",value]], - ['(QUOTE T),nbody]] - loop := ["LOOP",exits,:sucs] - if vars then loop := - ["LET",[[v, i] for v in vars for i in inits], loop] - loop - -bfLp2(extrait,itl,body)== - EQCAR (itl,"ITERATORS")=>bfLp1(cons(extrait,CDR itl),body) - iters:=cdr itl - bfLpCross - ([["ITERATORS",extrait,:CDAR iters],:CDR iters],body) - -bfOpReduce(op,init,y,itl)== - g:=bfGenSymbol() - body:= - EQ(op,"AND")=> - bfMKPROGN [["SETQ",g,y], - ['COND, [['NOT,g],['RETURN,'NIL]]]] - EQ(op,"OR") => - bfMKPROGN [["SETQ",g,y], - ['COND, [g,['RETURN,g]]]] - ['SETQ,g,[op,g,y]] - if null init - then - g1:=bfGenSymbol() - init:=['CAR,g1] - y:=['CDR,g1] - extrait:= [[[g],[init],[],[],[],[g]]] - bfMKPROGN [['L%T,g1,y],bfLp2(extrait,itl,body)] - else - init:=car init - extrait:= [[[g],[init],[],[],[],[g]]] - bfLp2(extrait,itl,body) - -bfLoop1 body == bfLp (bfIterators nil,body) - -bfSegment1(lo)== ["SEGMENT",lo,nil] - -bfSegment2(lo,hi)== ["SEGMENT",lo,hi] - -bfForInBy(variable,collection,step)== - bfFor(variable,collection,step) - -bfForin(lhs,U)==bfFor(lhs,U,1) - -bfLocal(a,b)== - EQ(b,"FLUID")=> compFluid a - EQ(b,"fluid")=> compFluid a - EQ(b,"local") => compFluid a - -- $typings:=cons(["TYPE",b,a],$typings) - a - -bfTake(n,x)== - null x=>x - n=0 => nil - cons(car x,bfTake(n-1,cdr x)) - -bfDrop(n,x)== - null x or n=0 =>x - bfDrop(n-1,cdr x) - -bfDefSequence l == ['SEQ,: l] - -bfReturnNoName a == - ["RETURN",a] - -bfSUBLIS(p,e)== - ATOM e=>bfSUBLIS1(p,e) - EQCAR(e,"QUOTE")=>e - cons(bfSUBLIS(p,car e),bfSUBLIS(p,cdr e)) - -+++ Returns e/p, where e is an atom. We assume that the -+++ DEFs form a system admitting a fix point; otherwise we may -+++ loop forever. That can happen only if nullary goats -+++ are recursive -- which they are not supposed to be. -+++ We don't enforce that restriction though. -bfSUBLIS1(p,e)== - null p =>e - f:=CAR p - EQ(CAR f,e)=> bfSUBLIS(p, CDR f) - bfSUBLIS1(cdr p,e) - -defSheepAndGoats(x)== - EQCAR (x,"DEF") => - [def,op,args,body]:=x - argl:=if bfTupleP args - then cdr args - else [args] - if null argl - then - opassoc:=[[op,:body]] - [opassoc,[],[]] - else - op1:=INTERN CONCAT(PNAME $op,'",",PNAME op) - opassoc:=[[op,:op1]] - defstack:=[["DEF",op1,args,body]] - [opassoc,defstack,[]] - EQCAR (x,"SEQ") => defSheepAndGoatsList(cdr x) - [[],[],[x]] - -defSheepAndGoatsList(x)== - if null x - then [[],[],[]] - else - [opassoc,defs,nondefs] := defSheepAndGoats car x - [opassoc1,defs1,nondefs1] := defSheepAndGoatsList cdr x - [append(opassoc,opassoc1),append(defs,defs1), - append(nondefs,nondefs1)] ---% LET - -bfLetForm(lhs,rhs) == ['L%T,lhs,rhs] - -bfLET1(lhs,rhs) == - IDENTP lhs => bfLetForm(lhs,rhs) - lhs is ['FLUID,.] => bfLetForm(lhs,rhs) - IDENTP rhs and not bfCONTAINED(rhs,lhs) => - rhs1 := bfLET2(lhs,rhs) - EQCAR(rhs1,'L%T) => bfMKPROGN [rhs1,rhs] - EQCAR(rhs1,'PROGN) => APPEND(rhs1,[rhs]) - if IDENTP CAR rhs1 then rhs1 := CONS(rhs1,NIL) - bfMKPROGN [:rhs1,rhs] - CONSP(rhs) and EQCAR(rhs,'L%T) and IDENTP(name := CADR rhs) => - -- handle things like [a] := x := foo - l1 := bfLET1(name,CADDR rhs) - l2 := bfLET1(lhs,name) - EQCAR(l2,'PROGN) => bfMKPROGN [l1,:CDR l2] - if IDENTP CAR l2 then l2 := cons(l2,nil) - bfMKPROGN [l1,:l2,name] - g := INTERN CONCAT('"LETTMP#",STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - rhs1 := ['L%T,g,rhs] - let1 := bfLET1(lhs,g) - EQCAR(let1,'PROGN) => bfMKPROGN [rhs1,:CDR let1] - if IDENTP CAR let1 then let1 := CONS(let1,NIL) - bfMKPROGN [rhs1,:let1,g] - -bfCONTAINED(x,y)== - EQ(x,y) => true - ATOM y=> false - bfCONTAINED(x,car y) or bfCONTAINED(x,cdr y) - -bfLET2(lhs,rhs) == - IDENTP lhs => bfLetForm(lhs,rhs) - NULL lhs => NIL - lhs is ['FLUID,.] => bfLetForm(lhs,rhs) - lhs is ['L%T,a,b] => - a := bfLET2(a,rhs) - null (b := bfLET2(b,rhs)) => a - ATOM b => [a,b] - CONSP CAR b => CONS(a,b) - [a,b] - lhs is ['CONS,var1,var2] => - var1 = "DOT" or (CONSP(var1) and EQCAR(var1,'QUOTE)) => - bfLET2(var2,addCARorCDR('CDR,rhs)) - l1 := bfLET2(var1,addCARorCDR('CAR,rhs)) - null var2 or EQ(var2,"DOT") =>l1 - if CONSP l1 and ATOM CAR l1 then l1 := cons(l1,nil) - IDENTP var2 => - [:l1,bfLetForm(var2,addCARorCDR('CDR,rhs))] - l2 := bfLET2(var2,addCARorCDR('CDR,rhs)) - if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - APPEND(l1,l2) - lhs is ['APPEND,var1,var2] => - patrev := bfISReverse(var2,var1) - rev := ['REVERSE,rhs] - g := INTERN CONCAT('"LETTMP#", STRINGIMAGE $letGenVarCounter) - $letGenVarCounter := $letGenVarCounter + 1 - l2 := bfLET2(patrev,g) - if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - var1 = "DOT" => [['L%T,g,rev],:l2] - last l2 is ['L%T, =var1, val1] => - [['L%T,g,rev],:REVERSE CDR REVERSE l2, - bfLetForm(var1,['NREVERSE,val1])] - [['L%T,g,rev],:l2,bfLetForm(var1,['NREVERSE,var1])] - lhs is ["EQUAL",var1] => - ['COND,[["EQUAL",var1,rhs],var1]] - -- The original expression may be one that involves literals as - -- sub-patterns, e.g. - -- ['SEQ, :l, ['exit, 1, x]] := item - -- We continue the processing as if that expression had been written - -- item is ['SEQ, :l, ['exit, 1, x]] - -- and generate appropriate codes. - -- -- gdr/2007-04-02. - isPred := - $inDefIS => bfIS1(rhs,lhs) - bfIS(rhs,lhs) - ['COND,[isPred,rhs]] - - -bfLET(lhs,rhs) == - $letGenVarCounter : local := 1 --- $inbfLet : local := true - bfLET1(lhs,rhs) - -addCARorCDR(acc,expr) == - NULL CONSP expr => [acc,expr] - acc = 'CAR and EQCAR(expr,'REVERSE) => - ["CAR",["LAST",:CDR expr]] - -- cons('last,CDR expr) - funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR) - p := bfPosition(CAR expr,funs) - p = -1 => [acc,expr] - funsA := '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR CAAADR - CAADDR CADAAR CADDAR CADADR CADDDR) - funsR := '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR CDAADR - CDADDR CDDAAR CDDDAR CDDADR CDDDDR) - if acc = 'CAR then CONS(funsA.p,CDR expr) - else CONS(funsR.p,CDR expr) - -bfPosition(x,l) == bfPosn(x,l,0) -bfPosn(x,l,n) == - null l => -1 - x=first l => n - bfPosn(x,rest l,n+1) - ---% IS - -bfISApplication(op,left,right)== - EQ(op ,"IS") => bfIS(left,right) - EQ(op ,"ISNT") => bfNOT bfIS(left,right) - [op ,left,right] - -bfIS(left,right)== - $isGenVarCounter:local :=1 - $inDefIS :local :=true - bfIS1(left,right) - -bfISReverse(x,a) == - x is ['CONS,:.] => - NULL CADDR x => ['CONS,CADR x, a] - y := bfISReverse(CADDR x, NIL) - RPLACA(CDDR y,['CONS,CADR x,a]) - y - bpSpecificErrorHere '"Error in bfISReverse" - bpTrap() - -bfIS1(lhs,rhs) == - NULL rhs => - ['NULL,lhs] - STRINGP rhs => - ['EQ,lhs,['QUOTE,INTERN rhs]] - NUMBERP rhs => - ["EQUAL",lhs,rhs] - ATOM rhs => - ['PROGN,bfLetForm(rhs,lhs),''T] - rhs is ['QUOTE,a] => - IDENTP a => ['EQ,lhs,rhs] - ["EQUAL",lhs,rhs] - rhs is ['L%T,c,d] => - l := - bfLET(c,lhs) --- $inbfLet => bfLET1(c,lhs) --- bfLET(c,lhs) - bfAND [bfIS1(lhs,d),bfMKPROGN [l,''T]] - rhs is ["EQUAL",a] => - ["EQUAL",lhs,a] - CONSP lhs => - g := INTERN CONCAT('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - bfMKPROGN [['L%T,g,lhs],bfIS1(g,rhs)] - rhs is ['CONS,a,b] => - a = "DOT" => - NULL b => - bfAND [['CONSP,lhs], - ['EQ,['CDR,lhs],'NIL]] - bfAND [['CONSP,lhs], - bfIS1(['CDR,lhs],b)] - NULL b => - bfAND [['CONSP,lhs], - ['EQ,['CDR,lhs],'NIL],_ - bfIS1(['CAR,lhs],a)] - b = "DOT" => - bfAND [['CONSP,lhs],bfIS1(['CAR,lhs],a)] - a1 := bfIS1(['CAR,lhs],a) - b1 := bfIS1(['CDR,lhs],b) - a1 is ['PROGN,c,''T] and b1 is ['PROGN,:cls] => - bfAND [['CONSP,lhs],bfMKPROGN [c,:cls]] - bfAND [['CONSP,lhs],a1,b1] - rhs is ['APPEND,a,b] => - patrev := bfISReverse(b,a) - g := INTERN CONCAT('"ISTMP#",STRINGIMAGE $isGenVarCounter) - $isGenVarCounter := $isGenVarCounter + 1 - rev := bfAND [['CONSP,lhs],['PROGN,['L%T,g,['REVERSE,lhs]],''T]] - l2 := bfIS1(g,patrev) - if CONSP l2 and ATOM CAR l2 then l2 := cons(l2,nil) - a = "DOT" => bfAND [rev,:l2] - bfAND [rev,:l2,['PROGN,bfLetForm(a,['NREVERSE,a]),''T]] - bpSpecificErrorHere '"bad IS code is generated" - bpTrap() - -bfApplication(bfop, bfarg) == - if bfTupleP bfarg - then cons(bfop,CDR bfarg) - else cons(bfop,[bfarg]) - - -++ Token renaming. New Boot and Old Boot differs in the set of -++ tokens they rename. When converting code written in Old Boot -++ to New Boot, it is helpful to have some noise about potential -++ divergence in semantics. So, when compiling with --boot=old, -++ we compute the renaming in both Old Boot and New Boot and compare -++ the results. If they differ, we prefer the old meaning, with some -++ warnings. Notice that the task is compounded by the fact the -++ tokens in both language do not always agreee. -++ However, to minimize the flood of false positive, we -++ keep a list of symbols which apparently differ in meanings, but -++ which have been verified to agree. -++ This is a valuable automated tool during the transition period. - --- return the meaning of the x in Old Boot. -bfGetOldBootName x == - a := GET(x, "OLD-BOOT") => car a - x - --- returns true if x has same meaning in both Old Boot and New Boot. -bfSameMeaning x == - GET(x, 'RENAME_-OK) - --- returns the meaning of x in the appropriate Boot dialect. -bfReName x== - newName := - a := GET(x,"SHOERENAME") => car a - x - $translatingOldBoot and not bfSameMeaning x => - oldName := bfGetOldBootName x - if newName ^= oldName then - warn [PNAME x, '" as `", PNAME newName, _ - '"_' differs from Old Boot `", PNAME oldName, '"_'"] - oldName - newName - - -bfInfApplication(op,left,right)== - 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 [left,right] - EQ(op,"AND") => bfAND [left,right] - [op,left,right] - -bfNOT x== - x is ["NOT",a]=> a - x is ["NULL",a]=> a - ["NOT",x] - -bfFlatten(op, x) == - EQCAR(x,op) => CDR x - [x] - -bfOR l == - null l => NIL - null cdr l => CAR l - ["OR",:[:bfFlatten("OR",c) for c in l]] - -bfAND l == - null l=> 'T - null cdr l => CAR l - ["AND",:[:bfFlatten("AND",c) for c in l]] - - -defQuoteId x== EQCAR(x,"QUOTE") and IDENTP CADR x - -bfSmintable x== - INTEGERP x or CONSP x and - MEMQ(CAR x, '(SIZE LENGTH)) - -bfQ(l,r)== - if bfSmintable l or bfSmintable r - then ["EQL",l,r] - else if defQuoteId l or defQuoteId r - then ["EQ",l,r] - else - if null l - then ["NULL",r] - else if null r - then ["NULL",l] - else ["EQUAL",l,r] - -bfLessp(l,r)== - if r=0 - then ["MINUSP", l] - else ["<",l,r] - -bfMDef (defOp,op,args,body) == - argl:=if bfTupleP args then cdr args else [args] - [gargl,sgargl,nargl,largl]:=bfGargl argl - sb:=[cons(i,j) for i in nargl for j in sgargl] - body:= SUBLIS(sb,body) - sb2 := [["CONS",["QUOTE",i],j] for i in sgargl for j in largl] - body := ["SUBLIS",["LIST",:sb2],["QUOTE",body]] - lamex:= ["MLAMBDA",gargl,body] - def:= [op,lamex] - bfTuple - cons(shoeComp def,[:shoeComps bfDef1 d for d in $wheredefs]) - -bfGargl argl== - if null argl - then [[],[],[],[]] - else - [a,b,c,d]:=bfGargl cdr argl - if car argl="&REST" - then [cons(car argl,b),b,c, - cons(["CONS",["QUOTE","LIST"],car d],cdr d)] - else - f:=bfGenSymbol() - [cons(f,a),cons(f,b),cons(car argl,c),cons(f,d)] - -bfDef1 [defOp,op,args,body] == - argl:=if bfTupleP args then cdr args else [args] - [quotes,control,arglp,body]:=bfInsertLet (argl,body) - quotes=>shoeLAM(op,arglp,control,body) - [[op,["LAMBDA",arglp,body]]] - -shoeLAM (op,args,control,body)== - margs :=bfGenSymbol() - innerfunc:=INTERN(CONCAT(PNAME op,",LAM")) - [[innerfunc,["LAMBDA",args,body]], - [op,["MLAMBDA",["&REST",margs],["CONS",["QUOTE", innerfunc], - ["WRAP",margs, ["QUOTE", control]]]]]] - -bfDef(defOp,op,args,body) == - $bfClamming => - [.,op1,arg1,:body1]:=shoeComp first bfDef1 [defOp,op,args,body] - bfCompHash(op1,arg1,body1) - bfTuple - [:shoeComps bfDef1 d for d in cons([defOp,op,args,body],$wheredefs)] - -shoeComps x==[shoeComp def for def in x] -shoeComp x== - a:=shoeCompTran CADR x - if EQCAR(a,"LAMBDA") - then ["DEFUN",CAR x,CADR a,:CDDR a] - else ["DEFMACRO",CAR x,CADR a,:CDDR a] - -bfInsertLet(x,body)== - if null x - then [false,nil,x,body] - else - if x is ["&REST",a] - then if a is ["QUOTE",b] - then [true,"QUOTE",["&REST",b],body] - else [false,nil,x,body] - else - [b,norq,name1,body1]:= bfInsertLet1 (car x,body) - [b1,norq1,name2,body2]:= bfInsertLet (cdr x,body1) - [b or b1,cons(norq,norq1),cons(name1,name2),body2] - -bfInsertLet1(y,body)== - if y is ["L%T",l,r] - then [false,nil,l,bfMKPROGN [bfLET(r,l),body]] - else if IDENTP y - then [false,nil,y,body] - else - if y is ["BVQUOTE",b] - then [true,"QUOTE",b,body] - else - g:=bfGenSymbol() - ATOM y => [false,nil,g,body] - [false,nil,g,bfMKPROGN [bfLET(compFluidize y,g),body]] - -shoeCompTran x== - lamtype:=CAR x - args :=CADR x - body :=CDDR x - $fluidVars:local:=nil - $locVars:local:=nil - $dollarVars:local:=nil - shoeCompTran1 body - $locVars:=SETDIFFERENCE(SETDIFFERENCE($locVars, - $fluidVars),shoeATOMs args) - body:= - if $fluidVars or $locVars or $dollarVars or $typings - then - lvars:=append($fluidVars,$locVars) - $fluidVars:=UNION($fluidVars,$dollarVars) - if null $fluidVars - then - null $typings=> shoePROG(lvars,body) - shoePROG(lvars,[["DECLARE",:$typings],:body]) - else - fvars:=["DECLARE",["SPECIAL",:$fluidVars]] - null $typings => shoePROG(lvars,[fvars,:body]) - shoePROG(lvars,[fvars,["DECLARE",:$typings],:body]) - else shoePROG([], body) - fl:=shoeFluids args - body:=if fl - then - fvs:=["DECLARE",["SPECIAL",:fl]] - cons(fvs,body) - else body - [lamtype,args, :body] - -shoePROG(v,b)== - null b => [["PROG", v]] - [:blist,blast] := b - [["PROG",v,:blist,["RETURN", blast]]] - -shoeFluids x== - if null x - then nil - else if IDENTP x and bfBeginsDollar x - then [x] - else - if EQCAR(x,"QUOTE") - then [] - else - if ATOM x - then nil - else append(shoeFluids car x,shoeFluids cdr x) -shoeATOMs x== - if null x - then nil - else if ATOM x - then [x] - else append(shoeATOMs car x,shoeATOMs cdr x) - -shoeCompTran1 x== - ATOM x=> - IDENTP x and bfBeginsDollar x=> - $dollarVars:= - MEMQ(x,$dollarVars)=>$dollarVars - cons(x,$dollarVars) - nil - U:=car x - EQ(U,"QUOTE")=>nil - x is ["L%T",l,r]=> - RPLACA (x,"SETQ") - shoeCompTran1 r - IDENTP l => - not bfBeginsDollar l=> - $locVars:= - MEMQ(l,$locVars)=>$locVars - cons(l,$locVars) - $dollarVars:= - MEMQ(l,$dollarVars)=>$dollarVars - cons(l,$dollarVars) - EQCAR(l,"FLUID")=> - $fluidVars:= - MEMQ(CADR l,$fluidVars)=>$fluidVars - cons(CADR l,$fluidVars) - RPLACA (CDR x,CADR l) - MEMQ(U,'(PROG LAMBDA))=> - newbindings:=nil - for y in CADR x repeat - not MEMQ(y,$locVars)=> - $locVars:=cons(y,$locVars) - newbindings:=cons(y,newbindings) - res:=shoeCompTran1 CDDR x - $locVars:=[y for y in $locVars | not MEMQ(y,newbindings)] - shoeCompTran1 car x - shoeCompTran1 cdr x - -bfTagged(a,b)== - IDENTP a => - EQ(b,"FLUID") => bfLET(compFluid a,NIL) - EQ(b,"fluid") => bfLET(compFluid a,NIL) - EQ(b,"local") => bfLET(compFluid a,NIL) - $typings:=cons(["TYPE",b,a],$typings) - a - ["THE",b,a] - -bfAssign(l,r)== - if bfTupleP l then bfSetelt(CADR l,CDDR l ,r) else bfLET(l,r) - -bfSetelt(e,l,r)== - if null cdr l - then defSETELT(e,car l,r) - else bfSetelt(bfElt(e,car l),cdr l,r) - -bfElt(expr,sel)== - y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION") - y=> - INTEGERP y => ["ELT",expr,y] - [y,expr] - ["ELT",expr,sel] - -defSETELT(var,sel,expr)== - y:=SYMBOLP sel and GET(sel,"SHOESELFUNCTION") - y=> - INTEGERP y => ["SETF",["ELT",var,y],expr] - ["SETF",[y,var],expr] - ["SETF",["ELT",var,sel],expr] - -bfIfThenOnly(a,b)== - b1:=if EQCAR (b,"PROGN") then CDR b else [b] - ["COND",[a,:b1]] - -bfIf(a,b,c)== - b1:=if EQCAR (b,"PROGN") then CDR b else [b] - EQCAR (c,"COND") => ["COND",[a,:b1],:CDR c] - c1:=if EQCAR (c,"PROGN") then CDR c else [c] - ["COND",[a,:b1],['(QUOTE T),:c1]] - -bfExit(a,b)== ["COND",[a,["IDENTITY",b]]] - -bfMKPROGN l== - a:=[:bfFlattenSeq c for c in tails l] - null a=> nil - null CDR a=> CAR a - ["PROGN",:a] - -bfFlattenSeq x == - null x=>NIL - f:=CAR x - ATOM f =>if CDR x then nil else [f] - EQCAR(f,"PROGN") => - CDR x=> [i for i in CDR f| not ATOM i] - CDR f - [f] - -bfSequence l == - null l=> NIL - transform:= [[a,b] for x in l while - x is ["COND",[a,["IDENTITY",b]]]] - no:=#transform - before:= bfTake(no,l) - aft := bfDrop(no,l) - null before => - null rest l => - f:=first l - if EQCAR(f,"PROGN") - then bfSequence CDR f - else f - bfMKPROGN [first l,bfSequence rest l] - null aft => ["COND",:transform] - ["COND",:transform,['(QUOTE T),bfSequence aft]] - -bfWhere (context,expr)== - [opassoc,defs,nondefs] := defSheepAndGoats context - a:=[[def,op,args,bfSUBLIS(opassoc,body)] - for d in defs |d is [def,op,args,body]] - $wheredefs:=append(a,$wheredefs) - bfMKPROGN bfSUBLIS(opassoc,NCONC(nondefs,[expr])) - ---shoeReadLispString(s,n)== --- n>= # s => nil --- [exp,ind]:=shoeReadLisp(s,n) --- null exp => nil --- cons(exp,shoeReadLispString(s,ind)) - -bfReadLisp string==bfTuple shoeReadLispString (string,0) - -bfCompHash(op,argl,body) == - auxfn:= INTERN CONCAT (PNAME op,'";") - computeFunction:= ["DEFUN",auxfn,argl,:body] - bfTuple [computeFunction,:bfMain(auxfn,op)] - -shoeCompileTimeEvaluation x == - ["EVAL-WHEN", [KEYWORD::COMPILE_-TOPLEVEL], x] - -shoeEVALANDFILEACTQ x== - ["EVAL-WHEN", [KEYWORD::EXECUTE, KEYWORD::LOAD_-TOPLEVEL], x] - -bfMain(auxfn,op)== - g1:= bfGenSymbol() - arg:=["&REST",g1] - computeValue := ['APPLY,["FUNCTION",auxfn],g1] - cacheName:= INTERN CONCAT (PNAME op,'";AL") - g2:= bfGenSymbol() - getCode:= ['GETHASH,g1,cacheName] - secondPredPair:= [['SETQ,g2,getCode],g2] - putCode:= ['SETF ,getCode,computeValue] - thirdPredPair:= ['(QUOTE T),putCode] - codeBody:= ['PROG,[g2], - ['RETURN,['COND,secondPredPair,thirdPredPair]]] - mainFunction:= ["DEFUN",op,arg,codeBody] - - cacheType:= 'hash_-table - cacheResetCode:= ['SETQ,cacheName,['MAKE_-HASHTABLE, - ["QUOTE","UEQUAL"]]] - cacheCountCode:= ['hashCount,cacheName] - cacheVector:= - [op,cacheName,cacheType,cacheResetCode,cacheCountCode] - [mainFunction, - shoeEVALANDFILEACTQ - ["SETF",["GET", - ["QUOTE", op],["QUOTE",'cacheInfo]],["QUOTE", cacheVector]], - shoeEVALANDFILEACTQ cacheResetCode ] - -bfNameOnly x== - if x="t" - then ["T"] - else [x] - -bfNameArgs (x,y)== - y:=if EQCAR(y,"TUPLE") then CDR y else [y] - cons(x,y) - -bfStruct(name,arglist)== - bfTuple [bfCreateDef i for i in arglist] - -bfCreateDef x== - if null cdr x - then - f:=car x - ["SETQ",f,["LIST",["QUOTE",f]]] - else - a:=[bfGenSymbol() for i in cdr x] - ["DEFUN",car x,a,["CONS",["QUOTE",car x],["LIST",:a]]] - -bfCaseItem(x,y)==[x,y] - -bfCase(x,y)== - g:=bfGenSymbol() - g1:=bfGenSymbol() - a:=bfLET(g,x) - b:=bfLET(g1,["CDR",g]) - c:=bfCaseItems (g1,y) - bfMKPROGN [a,b,["CASE",["CAR", g],:c]] - -bfCaseItems(g,x)== [bfCI(g,i,j) for [i,j] in x] - -bfCI(g,x,y)== - a:=cdr x - if null a - then [car x,y] - else - b:=[[i,bfCARCDR(j,g)] for i in a for j in 0..] - [car x,["LET",b,y]] - -bfCARCDR (n,g)==[INTERN CONCAT ('"CA",bfDs n,'"R"),g] - -bfDs n== if n=0 then '"" else CONCAT('"D",bfDs(n-1)) - -@ - -<>= -(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-ast")) - -(IMPORT-MODULE "includer") - -(IN-PACKAGE "BOOTTRAN") - -(DEFPARAMETER |$bfClamming| NIL) - -(DEFTYPE |String| () 'STRING) - -(DEFTYPE |Symbol| () 'SYMBOL) - -(DEFTYPE |Sequence| () 'SEQUENCE) - -(DEFTYPE |List| () '(OR NIL CONS)) - -(DEFUN |Name| #0=(|bfVar#1|) (CONS '|Name| (LIST . #0#))) - -(DEFUN |Command| #0=(|bfVar#2|) (CONS '|Command| (LIST . #0#))) - -(DEFUN |Module| #0=(|bfVar#3|) (CONS '|Module| (LIST . #0#))) - -(DEFUN |Import| #0=(|bfVar#4|) (CONS '|Import| (LIST . #0#))) - -(DEFUN |TypeAlias| #0=(|bfVar#5| |bfVar#6| |bfVar#7|) - (CONS '|TypeAlias| (LIST . #0#))) - -(DEFUN |SuffixDot| #0=(|bfVar#8|) (CONS '|SuffixDot| (LIST . #0#))) - -(DEFUN |Quote| #0=(|bfVar#9|) (CONS '|Quote| (LIST . #0#))) - -(DEFUN |EqualName| #0=(|bfVar#10|) (CONS '|EqualName| (LIST . #0#))) - -(DEFUN |Colon| #0=(|bfVar#11|) (CONS '|Colon| (LIST . #0#))) - -(DEFUN |QualifiedName| #0=(|bfVar#12| |bfVar#13|) - (CONS '|QualifiedName| (LIST . #0#))) - -(DEFUN |Bracket| #0=(|bfVar#14|) (CONS '|Bracket| (LIST . #0#))) - -(DEFUN |UnboundedSegment| #0=(|bfVar#15|) - (CONS '|UnboundedSegment| (LIST . #0#))) - -(DEFUN |BoundedSgement| #0=(|bfVar#16| |bfVar#17|) - (CONS '|BoundedSgement| (LIST . #0#))) - -(DEFUN |Tuple| #0=(|bfVar#18|) (CONS '|Tuple| (LIST . #0#))) - -(DEFUN |ColonAppend| #0=(|bfVar#19| |bfVar#20|) - (CONS '|ColonAppend| (LIST . #0#))) - -(DEFUN |Is| #0=(|bfVar#21| |bfVar#22|) (CONS '|Is| (LIST . #0#))) - -(DEFUN |Isnt| #0=(|bfVar#23| |bfVar#24|) (CONS '|Isnt| (LIST . #0#))) - -(DEFUN |Reduce| #0=(|bfVar#25| |bfVar#26|) - (CONS '|Reduce| (LIST . #0#))) - -(DEFUN |PrefixExpr| #0=(|bfVar#27| |bfVar#28|) - (CONS '|PrefixExpr| (LIST . #0#))) - -(DEFUN |Call| #0=(|bfVar#29| |bfVar#30|) (CONS '|Call| (LIST . #0#))) - -(DEFUN |InfixExpr| #0=(|bfVar#31| |bfVar#32| |bfVar#33|) - (CONS '|InfixExpr| (LIST . #0#))) - -(DEFUN |ConstantDefinition| #0=(|bfVar#34| |bfVar#35|) - (CONS '|ConstantDefinition| (LIST . #0#))) - -(DEFUN |Definition| #0=(|bfVar#36| |bfVar#37| |bfVar#38| |bfVar#39|) - (CONS '|Definition| (LIST . #0#))) - -(DEFUN |Macro| #0=(|bfVar#40| |bfVar#41| |bfVar#42|) - (CONS '|Macro| (LIST . #0#))) - -(DEFUN |SuchThat| #0=(|bfVar#43|) (CONS '|SuchThat| (LIST . #0#))) - -(DEFUN |Assignment| #0=(|bfVar#44| |bfVar#45|) - (CONS '|Assignment| (LIST . #0#))) - -(DEFUN |While| #0=(|bfVar#46|) (CONS '|While| (LIST . #0#))) - -(DEFUN |Until| #0=(|bfVar#47|) (CONS '|Until| (LIST . #0#))) - -(DEFUN |For| #0=(|bfVar#48| |bfVar#49| |bfVar#50|) - (CONS '|For| (LIST . #0#))) - -(DEFUN |Exit| #0=(|bfVar#51| |bfVar#52|) (CONS '|Exit| (LIST . #0#))) - -(DEFUN |Iterators| #0=(|bfVar#53|) (CONS '|Iterators| (LIST . #0#))) - -(DEFUN |Cross| #0=(|bfVar#54|) (CONS '|Cross| (LIST . #0#))) - -(DEFUN |Repeat| #0=(|bfVar#55| |bfVar#56|) - (CONS '|Repeat| (LIST . #0#))) - -(DEFUN |Pile| #0=(|bfVar#57|) (CONS '|Pile| (LIST . #0#))) - -(DEFUN |Append| #0=(|bfVar#58|) (CONS '|Append| (LIST . #0#))) - -(DEFUN |Case| #0=(|bfVar#59| |bfVar#60|) (CONS '|Case| (LIST . #0#))) - -(DEFUN |Return| #0=(|bfVar#61|) (CONS '|Return| (LIST . #0#))) - -(DEFUN |Where| #0=(|bfVar#62| |bfVar#63|) - (CONS '|Where| (LIST . #0#))) - -(DEFUN |Structure| #0=(|bfVar#64| |bfVar#65|) - (CONS '|Structure| (LIST . #0#))) - -(DEFPARAMETER |$inDefIS| NIL) - -(DEFUN |bfGenSymbol| () - (PROG () - (DECLARE (SPECIAL |$GenVarCounter|)) - (RETURN - (PROGN - (SETQ |$GenVarCounter| (+ |$GenVarCounter| 1)) - (INTERN (CONCAT "bfVar#" (STRINGIMAGE |$GenVarCounter|))))))) - -(DEFUN |bfListOf| (|x|) (PROG () (RETURN |x|))) - -(DEFUN |bfColon| (|x|) (PROG () (RETURN (LIST 'COLON |x|)))) - -(DEFUN |bfColonColon| (|package| |name|) - (PROG () (RETURN (INTERN (SYMBOL-NAME |name|) |package|)))) - -(DEFUN |bfSymbol| (|x|) - (PROG () (RETURN (COND ((STRINGP |x|) |x|) ('T (LIST 'QUOTE |x|)))))) - -(DEFUN |bfDot| () (PROG () (RETURN 'DOT))) - -(DEFUN |bfSuffixDot| (|x|) (PROG () (RETURN (LIST |x| 'DOT)))) - -(DEFUN |bfEqual| (|name|) (PROG () (RETURN (LIST 'EQUAL |name|)))) - -(DEFUN |bfBracket| (|part|) (PROG () (RETURN |part|))) - -(DEFUN |bfPile| (|part|) (PROG () (RETURN |part|))) - -(DEFUN |bfAppend| (|x|) (PROG () (RETURN (APPLY #'APPEND |x|)))) - -(DEFUN |bfColonAppend| (|x| |y|) - (PROG (|a|) - (RETURN - (COND - ((NULL |x|) - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) - (PROGN (SETQ |a| (CDR |y|)) 'T)) - (LIST '&REST (CONS 'QUOTE |a|))) - (#0='T (LIST '&REST |y|)))) - (#0# (CONS (CAR |x|) (|bfColonAppend| (CDR |x|) |y|))))))) - -(DEFUN |bfDefinition| (|bflhsitems| |bfrhs| |body|) - (PROG () (RETURN (LIST 'DEF |bflhsitems| |bfrhs| |body|)))) - -(DEFUN |bfMDefinition| (|bflhsitems| |bfrhs| |body|) - (PROG () (RETURN (|bfMDef| 'MDEF |bflhsitems| |bfrhs| |body|)))) - -(DEFUN |bfCompDef| (|x|) - (PROG (|body| |ISTMP#3| |args| |ISTMP#2| |op| |ISTMP#1| |def| - |bfVar#67| |bfVar#66|) - (RETURN - (PROGN - (SETQ |bfVar#66| |x|) - (SETQ |bfVar#67| (CDR |bfVar#66|)) - (CASE (CAR |bfVar#66|) - (|ConstantDefinition| - (LET ((|n| (CAR |bfVar#67|)) (|e| (CADR |bfVar#67|))) - |x|)) - (T (COND - ((AND (CONSP |x|) - (PROGN - (SETQ |def| (CAR |x|)) - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |op| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |args| (CAR |ISTMP#2|)) - (SETQ |ISTMP#3| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CDR |ISTMP#3|) NIL) - (PROGN - (SETQ |body| (CAR |ISTMP#3|)) - 'T)))))))) - (|bfDef| |def| |op| |args| |body|)) - ('T (|coreError| "invalid AST"))))))))) - -(DEFUN |bfBeginsDollar| (|x|) - (PROG () (RETURN (EQL (ELT "$" 0) (ELT (PNAME |x|) 0))))) - -(DEFUN |compFluid| (|id|) (PROG () (RETURN (LIST 'FLUID |id|)))) - -(DEFUN |compFluidize| (|x|) - (PROG () - (RETURN - (COND - ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) (|compFluid| |x|)) - ((ATOM |x|) |x|) - ((EQCAR |x| 'QUOTE) |x|) - ('T - (CONS (|compFluidize| (CAR |x|)) (|compFluidize| (CDR |x|)))))))) - -(DEFUN |bfTuple| (|x|) (PROG () (RETURN (CONS 'TUPLE |x|)))) - -(DEFUN |bfTupleP| (|x|) (PROG () (RETURN (EQCAR |x| 'TUPLE)))) - -(DEFUN |bfTupleIf| (|x|) - (PROG () - (RETURN (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#69| NIL) (|bfVar#68| |a|) (|x| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#68|) - (PROGN (SETQ |x| (CAR |bfVar#68|)) NIL)) - (RETURN |bfVar#69|)) - ('T - (PROGN - (SETQ |bfVar#69| - (AND (CONSP |x|) (EQ (CAR |x|) 'COLON) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (EQ (CDR |ISTMP#1|) NIL))))) - (COND (|bfVar#69| (RETURN |bfVar#69|)))))) - (SETQ |bfVar#68| (CDR |bfVar#68|)))) - (|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|))))) - -(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|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#2|)) #0='T))))) - (PROGN (SETQ |l1| (CDR |l|)) #0#)) - (COND - (|l1| (LIST 'APPEND |a| (|bfMakeCons| |l1|))) - (#1='T |a|))) - (#1# (LIST 'CONS (CAR |l|) (|bfMakeCons| (CDR |l|)))))))) - -(DEFUN |bfFor| (|bflhs| U |step|) - (PROG () - (RETURN - (COND - ((EQCAR U '|tails|) (|bfForTree| 'ON |bflhs| (CADR U))) - ((EQCAR U 'SEGMENT) - (|bfSTEP| |bflhs| (CADR U) |step| (CADDR U))) - ('T (|bfForTree| 'IN |bflhs| U)))))) - -(DEFUN |bfForTree| (OP |lhs| |whole|) - (PROG (G) - (RETURN - (PROGN - (SETQ |whole| - (COND - ((|bfTupleP| |whole|) (|bfMakeCons| (CDR |whole|))) - (#0='T |whole|))) - (COND - ((ATOM |lhs|) (|bfINON| (LIST OP |lhs| |whole|))) - (#1='T - (PROGN - (SETQ |lhs| - (COND - ((|bfTupleP| |lhs|) (CADR |lhs|)) - (#0# |lhs|))) - (COND - ((EQCAR |lhs| 'L%T) - (PROGN - (SETQ G (CADR |lhs|)) - (APPEND (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G (CADDR |lhs|)))))) - (#1# - (PROGN - (SETQ G (|bfGenSymbol|)) - (APPEND (|bfINON| (LIST OP G |whole|)) - (|bfSuchthat| (|bfIS| G |lhs|))))))))))))) - -(DEFUN |bfSTEP| (|id| |fst| |step| |lst|) - (PROG (|suc| |ex| |pred| |final| |g2| |inc| |g1| |initval| |initvar|) - (RETURN - (PROGN - (SETQ |initvar| (LIST |id|)) - (SETQ |initval| (LIST |fst|)) - (SETQ |inc| - (COND - ((ATOM |step|) |step|) - (#0='T (SETQ |g1| (|bfGenSymbol|)) - (SETQ |initvar| (CONS |g1| |initvar|)) - (SETQ |initval| (CONS |step| |initval|)) |g1|))) - (SETQ |final| - (COND - ((ATOM |lst|) |lst|) - (#0# (SETQ |g2| (|bfGenSymbol|)) - (SETQ |initvar| (CONS |g2| |initvar|)) - (SETQ |initval| (CONS |lst| |initval|)) |g2|))) - (SETQ |ex| - (COND - ((NULL |lst|) NIL) - ((INTEGERP |inc|) - (PROGN - (SETQ |pred| (COND ((MINUSP |inc|) '<) (#0# '>))) - (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 |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|))))))) - -(DEFUN |bfIN| (|x| E) - (PROG (|g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (LIST (LIST (LIST |g| |x|) (LIST E NIL) - (LIST (LIST 'SETQ |g| (LIST 'CDR |g|))) NIL - (LIST (LIST 'OR (LIST 'ATOM |g|) - (LIST 'PROGN - (LIST 'SETQ |x| (LIST 'CAR |g|)) - 'NIL))) - NIL)))))) - -(DEFUN |bfON| (|x| E) - (PROG () - (RETURN - (LIST (LIST (LIST |x|) (LIST E) - (LIST (LIST 'SETQ |x| (LIST 'CDR |x|))) NIL - (LIST (LIST 'ATOM |x|)) NIL))))) - -(DEFUN |bfSuchthat| (|p|) - (PROG () (RETURN (LIST (LIST NIL NIL NIL (LIST |p|) NIL NIL))))) - -(DEFUN |bfWhile| (|p|) - (PROG () - (RETURN (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)))))) - -(DEFUN |bfIterators| (|x|) (PROG () (RETURN (CONS 'ITERATORS |x|)))) - -(DEFUN |bfCross| (|x|) (PROG () (RETURN (CONS 'CROSS |x|)))) - -(DEFUN |bfLp| (|iters| |body|) - (PROG () - (RETURN - (COND - ((EQCAR |iters| 'ITERATORS) (|bfLp1| (CDR |iters|) |body|)) - ('T (|bfLpCross| (CDR |iters|) |body|)))))) - -(DEFUN |bfLpCross| (|iters| |body|) - (PROG () - (RETURN - (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#72| NIL) (|bfVar#70| |f|) (|i| NIL) - (|bfVar#71| |r|) (|j| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#70|) - (PROGN (SETQ |i| (CAR |bfVar#70|)) NIL) - (ATOM |bfVar#71|) - (PROGN (SETQ |j| (CAR |bfVar#71|)) NIL)) - (RETURN (NREVERSE |bfVar#72|))) - ('T - (SETQ |bfVar#72| (CONS (APPEND |i| |j|) |bfVar#72|)))) - (SETQ |bfVar#70| (CDR |bfVar#70|)) - (SETQ |bfVar#71| (CDR |bfVar#71|))))))))) - -(DEFUN |bfReduce| (|op| |y|) - (PROG (|it| |ny| |g2| |body| |g1| |g| |init| |a|) - (RETURN - (PROGN - (SETQ |a| - (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) (#0='T |op|))) - (SETQ |op| (|bfReName| |a|)) - (SETQ |init| (GET |op| 'SHOETHETA)) - (SETQ |g| (|bfGenSymbol|)) - (SETQ |g1| (|bfGenSymbol|)) - (SETQ |body| (LIST 'SETQ |g| (LIST |op| |g1| |g|))) - (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|)))) - (#0# (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 (|init| |a| |itl| |body|) - (RETURN - (COND - ((EQCAR |y| 'COLLECT) (SETQ |body| (ELT |y| 1)) - (SETQ |itl| (ELT |y| 2)) - (SETQ |a| - (COND ((EQCAR |op| 'QUOTE) (CADR |op|)) (#0='T |op|))) - (SETQ |op| (|bfReName| |a|)) - (SETQ |init| (GET |op| 'SHOETHETA)) - (|bfOpReduce| |op| |init| |body| |itl|)) - (#0# (SETQ |a| (|bfTupleConstruct| (ELT |y| 1))) - (|bfReduce| |op| |a|)))))) - -(DEFUN |bfDCollect| (|y| |itl|) - (PROG () (RETURN (LIST 'COLLECT |y| |itl|)))) - -(DEFUN |bfDTuple| (|x|) (PROG () (RETURN (LIST 'DTUPLE |x|)))) - -(DEFUN |bfCollect| (|y| |itl|) - (PROG (|newBody| |a| |ISTMP#1|) - (RETURN - (COND - ((AND (CONSP |y|) (EQ (CAR |y|) 'COLON) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) 'T)))) - (|bf0APPEND| |a| |itl|)) - ((AND (CONSP |y|) (EQ (CAR |y|) 'TUPLE)) - (PROGN - (SETQ |newBody| (|bfConstruct| |y|)) - (|bf0APPEND| |newBody| |itl|))) - ('T (|bf0COLLECT| |y| |itl|)))))) - -(DEFUN |bf0COLLECT| (|y| |itl|) - (PROG () (RETURN (|bfListReduce| 'CONS |y| |itl|)))) - -(DEFUN |bf0APPEND| (|y| |itl|) - (PROG (|extrait| |body| |g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (SETQ |body| - (LIST 'SETQ |g| (LIST 'APPEND (LIST 'REVERSE |y|) |g|))) - (SETQ |extrait| - (LIST (LIST (LIST |g|) (LIST NIL) NIL NIL NIL - (LIST (LIST 'NREVERSE |g|))))) - (|bfLp2| |extrait| |itl| |body|))))) - -(DEFUN |bfListReduce| (|op| |y| |itl|) - (PROG (|extrait| |body| |g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (SETQ |body| (LIST 'SETQ |g| (LIST |op| |y| |g|))) - (SETQ |extrait| - (LIST (LIST (LIST |g|) (LIST NIL) NIL NIL NIL - (LIST (LIST 'NREVERSE |g|))))) - (|bfLp2| |extrait| |itl| |body|))))) - -(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|) - (#2='T (|bfAND| (APPEND |filters| (CONS |body| NIL)))))) - (SETQ |value| (COND ((NULL |value|) 'NIL) (#2# (CAR |value|)))) - (SETQ |exits| - (LIST 'COND - (LIST (|bfOR| |exits|) (LIST 'RETURN |value|)) - (LIST ''T |nbody|))) - (SETQ |loop| (CONS 'LOOP (CONS |exits| |sucs|))) - (COND - (|vars| (SETQ |loop| - (LIST 'LET - (LET ((|bfVar#75| NIL) - (|bfVar#73| |vars|) (|v| NIL) - (|bfVar#74| |inits|) (|i| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#73|) - (PROGN - (SETQ |v| (CAR |bfVar#73|)) - NIL) - (ATOM |bfVar#74|) - (PROGN - (SETQ |i| (CAR |bfVar#74|)) - NIL)) - (RETURN (NREVERSE |bfVar#75|))) - ('T - (SETQ |bfVar#75| - (CONS (LIST |v| |i|) |bfVar#75|)))) - (SETQ |bfVar#73| (CDR |bfVar#73|)) - (SETQ |bfVar#74| (CDR |bfVar#74|)))) - |loop|)))) - |loop|)))) - -(DEFUN |bfLp2| (|extrait| |itl| |body|) - (PROG (|iters|) - (RETURN - (COND - ((EQCAR |itl| 'ITERATORS) - (|bfLp1| (CONS |extrait| (CDR |itl|)) |body|)) - ('T - (PROGN - (SETQ |iters| (CDR |itl|)) - (|bfLpCross| - (CONS (CONS 'ITERATORS (CONS |extrait| (CDAR |iters|))) - (CDR |iters|)) - |body|))))))) - -(DEFUN |bfOpReduce| (|op| |init| |y| |itl|) - (PROG (|extrait| |g1| |body| |g|) - (RETURN - (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|))))))) - -(DEFUN |bfLoop1| (|body|) - (PROG () (RETURN (|bfLp| (|bfIterators| NIL) |body|)))) - -(DEFUN |bfSegment1| (|lo|) - (PROG () (RETURN (LIST 'SEGMENT |lo| NIL)))) - -(DEFUN |bfSegment2| (|lo| |hi|) - (PROG () (RETURN (LIST 'SEGMENT |lo| |hi|)))) - -(DEFUN |bfForInBy| (|variable| |collection| |step|) - (PROG () (RETURN (|bfFor| |variable| |collection| |step|)))) - -(DEFUN |bfForin| (|lhs| U) (PROG () (RETURN (|bfFor| |lhs| U 1)))) - -(DEFUN |bfLocal| (|a| |b|) - (PROG () - (RETURN - (COND - ((EQ |b| 'FLUID) (|compFluid| |a|)) - ((EQ |b| '|fluid|) (|compFluid| |a|)) - ((EQ |b| '|local|) (|compFluid| |a|)) - ('T |a|))))) - -(DEFUN |bfTake| (|n| |x|) - (PROG () - (RETURN - (COND - ((NULL |x|) |x|) - ((EQL |n| 0) NIL) - ('T (CONS (CAR |x|) (|bfTake| (- |n| 1) (CDR |x|)))))))) - -(DEFUN |bfDrop| (|n| |x|) - (PROG () - (RETURN - (COND - ((OR (NULL |x|) (EQL |n| 0)) |x|) - ('T (|bfDrop| (- |n| 1) (CDR |x|))))))) - -(DEFUN |bfDefSequence| (|l|) (PROG () (RETURN (CONS 'SEQ |l|)))) - -(DEFUN |bfReturnNoName| (|a|) (PROG () (RETURN (LIST 'RETURN |a|)))) - -(DEFUN |bfSUBLIS| (|p| |e|) - (PROG () - (RETURN - (COND - ((ATOM |e|) (|bfSUBLIS1| |p| |e|)) - ((EQCAR |e| 'QUOTE) |e|) - ('T - (CONS (|bfSUBLIS| |p| (CAR |e|)) (|bfSUBLIS| |p| (CDR |e|)))))))) - -(DEFUN |bfSUBLIS1| (|p| |e|) - (PROG (|f|) - (RETURN - (COND - ((NULL |p|) |e|) - (#0='T - (PROGN - (SETQ |f| (CAR |p|)) - (COND - ((EQ (CAR |f|) |e|) (|bfSUBLIS| |p| (CDR |f|))) - (#0# (|bfSUBLIS1| (CDR |p|) |e|))))))))) - -(DEFUN |defSheepAndGoats| (|x|) - (PROG (|defstack| |op1| |opassoc| |argl| |body| |args| |op| |def|) - (DECLARE (SPECIAL |$op|)) - (RETURN - (COND - ((EQCAR |x| 'DEF) - (PROGN - (SETQ |def| (CAR |x|)) - (SETQ |op| (CADR . #0=(|x|))) - (SETQ |args| (CADDR . #0#)) - (SETQ |body| (CADDDR . #0#)) - (SETQ |argl| - (COND - ((|bfTupleP| |args|) (CDR |args|)) - (#1='T (LIST |args|)))) - (COND - ((NULL |argl|) (SETQ |opassoc| (LIST (CONS |op| |body|))) - (LIST |opassoc| NIL NIL)) - (#1# - (SETQ |op1| - (INTERN (CONCAT (PNAME |$op|) "," (PNAME |op|)))) - (SETQ |opassoc| (LIST (CONS |op| |op1|))) - (SETQ |defstack| (LIST (LIST 'DEF |op1| |args| |body|))) - (LIST |opassoc| |defstack| NIL))))) - ((EQCAR |x| 'SEQ) (|defSheepAndGoatsList| (CDR |x|))) - ('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|))))))) - -(DEFUN |bfLetForm| (|lhs| |rhs|) - (PROG () (RETURN (LIST 'L%T |lhs| |rhs|)))) - -(DEFUN |bfLET1| (|lhs| |rhs|) - (PROG (|let1| |g| |l2| |l1| |name| |rhs1| |ISTMP#1|) - (DECLARE (SPECIAL |$letGenVarCounter|)) - (RETURN - (COND - ((IDENTP |lhs|) (|bfLetForm| |lhs| |rhs|)) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)))) - (|bfLetForm| |lhs| |rhs|)) - ((AND (IDENTP |rhs|) (NULL (|bfCONTAINED| |rhs| |lhs|))) - (PROGN - (SETQ |rhs1| (|bfLET2| |lhs| |rhs|)) - (COND - ((EQCAR |rhs1| 'L%T) (|bfMKPROGN| (LIST |rhs1| |rhs|))) - ((EQCAR |rhs1| 'PROGN) (APPEND |rhs1| (LIST |rhs|))) - (#0='T - (PROGN - (COND - ((IDENTP (CAR |rhs1|)) - (SETQ |rhs1| (CONS |rhs1| NIL)))) - (|bfMKPROGN| (APPEND |rhs1| (CONS |rhs| NIL)))))))) - ((AND (CONSP |rhs|) (EQCAR |rhs| 'L%T) - (IDENTP (SETQ |name| (CADR |rhs|)))) - (PROGN - (SETQ |l1| (|bfLET1| |name| (CADDR |rhs|))) - (SETQ |l2| (|bfLET1| |lhs| |name|)) - (COND - ((EQCAR |l2| 'PROGN) (|bfMKPROGN| (CONS |l1| (CDR |l2|)))) - (#0# - (PROGN - (COND - ((IDENTP (CAR |l2|)) (SETQ |l2| (CONS |l2| NIL)))) - (|bfMKPROGN| - (CONS |l1| (APPEND |l2| (CONS |name| NIL))))))))) - (#0# - (PROGN - (SETQ |g| - (INTERN (CONCAT "LETTMP#" - (STRINGIMAGE |$letGenVarCounter|)))) - (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) - (SETQ |rhs1| (LIST 'L%T |g| |rhs|)) - (SETQ |let1| (|bfLET1| |lhs| |g|)) - (COND - ((EQCAR |let1| 'PROGN) - (|bfMKPROGN| (CONS |rhs1| (CDR |let1|)))) - (#0# - (PROGN - (COND - ((IDENTP (CAR |let1|)) - (SETQ |let1| (CONS |let1| NIL)))) - (|bfMKPROGN| - (CONS |rhs1| (APPEND |let1| (CONS |g| NIL))))))))))))) - -(DEFUN |bfCONTAINED| (|x| |y|) - (PROG () - (RETURN - (COND - ((EQ |x| |y|) T) - ((ATOM |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|) - (DECLARE (SPECIAL |$inDefIS| |$letGenVarCounter|)) - (RETURN - (COND - ((IDENTP |lhs|) (|bfLetForm| |lhs| |rhs|)) - ((NULL |lhs|) NIL) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'FLUID) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL)))) - (|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|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0='T)))))) - (PROGN - (SETQ |a| (|bfLET2| |a| |rhs|)) - (COND - ((NULL (SETQ |b| (|bfLET2| |b| |rhs|))) |a|) - ((ATOM |b|) (LIST |a| |b|)) - ((CONSP (CAR |b|)) (CONS |a| |b|)) - (#1='T (LIST |a| |b|))))) - ((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|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |var2| (CAR |ISTMP#2|)) #0#)))))) - (COND - ((OR (EQ |var1| 'DOT) - (AND (CONSP |var1|) (EQCAR |var1| 'QUOTE))) - (|bfLET2| |var2| (|addCARorCDR| 'CDR |rhs|))) - (#1# - (PROGN - (SETQ |l1| (|bfLET2| |var1| (|addCARorCDR| 'CAR |rhs|))) - (COND - ((OR (NULL |var2|) (EQ |var2| 'DOT)) |l1|) - (#1# - (PROGN - (COND - ((AND (CONSP |l1|) (ATOM (CAR |l1|))) - (SETQ |l1| (CONS |l1| NIL)))) - (COND - ((IDENTP |var2|) - (APPEND |l1| - (CONS (|bfLetForm| |var2| - (|addCARorCDR| 'CDR |rhs|)) - NIL))) - (#1# - (PROGN - (SETQ |l2| - (|bfLET2| |var2| - (|addCARorCDR| 'CDR |rhs|))) - (COND - ((AND (CONSP |l2|) (ATOM (CAR |l2|))) - (SETQ |l2| (CONS |l2| NIL)))) - (APPEND |l1| |l2|))))))))))) - ((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|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |var2| (CAR |ISTMP#2|)) #0#)))))) - (PROGN - (SETQ |patrev| (|bfISReverse| |var2| |var1|)) - (SETQ |rev| (LIST 'REVERSE |rhs|)) - (SETQ |g| - (INTERN (CONCAT "LETTMP#" - (STRINGIMAGE |$letGenVarCounter|)))) - (SETQ |$letGenVarCounter| (+ |$letGenVarCounter| 1)) - (SETQ |l2| (|bfLET2| |patrev| |g|)) - (COND - ((AND (CONSP |l2|) (ATOM (CAR |l2|))) - (SETQ |l2| (CONS |l2| NIL)))) - (COND - ((EQ |var1| 'DOT) (CONS (LIST 'L%T |g| |rev|) |l2|)) - ((PROGN - (SETQ |ISTMP#1| (|last| |l2|)) - (AND (CONSP |ISTMP#1|) (EQ (CAR |ISTMP#1|) 'L%T) - (PROGN - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQUAL (CAR |ISTMP#2|) |var1|) - (PROGN - (SETQ |ISTMP#3| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CDR |ISTMP#3|) NIL) - (PROGN - (SETQ |val1| (CAR |ISTMP#3|)) - #0#))))))) - (CONS (LIST 'L%T |g| |rev|) - (APPEND (REVERSE (CDR (REVERSE |l2|))) - (CONS (|bfLetForm| |var1| - (LIST 'NREVERSE |val1|)) - NIL)))) - (#1# - (CONS (LIST 'L%T |g| |rev|) - (APPEND |l2| - (CONS (|bfLetForm| |var1| - (LIST 'NREVERSE |var1|)) - NIL))))))) - ((AND (CONSP |lhs|) (EQ (CAR |lhs|) 'EQUAL) - (PROGN - (SETQ |ISTMP#1| (CDR |lhs|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |var1| (CAR |ISTMP#1|)) #0#)))) - (LIST 'COND (LIST (LIST 'EQUAL |var1| |rhs|) |var1|))) - (#1# - (PROGN - (SETQ |isPred| - (COND - (|$inDefIS| (|bfIS1| |rhs| |lhs|)) - (#1# (|bfIS| |rhs| |lhs|)))) - (LIST 'COND (LIST |isPred| |rhs|)))))))) - -(DEFUN |bfLET| (|lhs| |rhs|) - (PROG (|$letGenVarCounter|) - (DECLARE (SPECIAL |$letGenVarCounter|)) - (RETURN - (PROGN (SETQ |$letGenVarCounter| 1) (|bfLET1| |lhs| |rhs|))))) - -(DEFUN |addCARorCDR| (|acc| |expr|) - (PROG (|funsR| |funsA| |p| |funs|) - (RETURN - (COND - ((NULL (CONSP |expr|)) (LIST |acc| |expr|)) - ((AND (EQ |acc| 'CAR) (EQCAR |expr| 'REVERSE)) - (LIST 'CAR (CONS 'LAST (CDR |expr|)))) - (#0='T - (PROGN - (SETQ |funs| - '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR - CDAAR CDDAR CDADR CDDDR)) - (SETQ |p| (|bfPosition| (CAR |expr|) |funs|)) - (COND - ((EQUAL |p| (- 1)) (LIST |acc| |expr|)) - (#0# - (PROGN - (SETQ |funsA| - '(CAAR CADR CAAAR CADAR CAADR CADDR CAAAAR CAADAR - CAAADR CAADDR CADAAR CADDAR CADADR CADDDR)) - (SETQ |funsR| - '(CDAR CDDR CDAAR CDDAR CDADR CDDDR CDAAAR CDADAR - CDAADR CDADDR CDDAAR CDDDAR CDDADR CDDDDR)) - (COND - ((EQ |acc| 'CAR) - (CONS (ELT |funsA| |p|) (CDR |expr|))) - ('T (CONS (ELT |funsR| |p|) (CDR |expr|))))))))))))) - -(DEFUN |bfPosition| (|x| |l|) (PROG () (RETURN (|bfPosn| |x| |l| 0)))) - -(DEFUN |bfPosn| (|x| |l| |n|) - (PROG () - (RETURN - (COND - ((NULL |l|) (- 1)) - ((EQUAL |x| (CAR |l|)) |n|) - ('T (|bfPosn| |x| (CDR |l|) (+ |n| 1))))))) - -(DEFUN |bfISApplication| (|op| |left| |right|) - (PROG () - (RETURN - (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|)) - (RETURN - (PROGN - (SETQ |$isGenVarCounter| 1) - (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|)) - (#0='T - (PROGN - (SETQ |y| (|bfISReverse| (CADDR |x|) NIL)) - (RPLACA (CDDR |y|) (LIST 'CONS (CADR |x|) |a|)) - |y|)))) - (#0# - (PROGN - (|bpSpecificErrorHere| "Error in bfISReverse") - (|bpTrap|))))))) - -(DEFUN |bfIS1| (|lhs| |rhs|) - (PROG (|l2| |rev| |patrev| |cls| |b1| |a1| |b| |g| |l| |d| |ISTMP#2| - |c| |a| |ISTMP#1|) - (DECLARE (SPECIAL |$isGenVarCounter|)) - (RETURN - (COND - ((NULL |rhs|) (LIST 'NULL |lhs|)) - ((STRINGP |rhs|) (LIST 'EQ |lhs| (LIST 'QUOTE (INTERN |rhs|)))) - ((NUMBERP |rhs|) (LIST 'EQUAL |lhs| |rhs|)) - ((ATOM |rhs|) (LIST 'PROGN (|bfLetForm| |rhs| |lhs|) ''T)) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |rhs|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0='T)))) - (COND - ((IDENTP |a|) (LIST 'EQ |lhs| |rhs|)) - (#1='T (LIST 'EQUAL |lhs| |rhs|)))) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |rhs|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |c| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |d| (CAR |ISTMP#2|)) #0#)))))) - (PROGN - (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|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0#)))) - (LIST 'EQUAL |lhs| |a|)) - ((CONSP |lhs|) - (PROGN - (SETQ |g| - (INTERN (CONCAT "ISTMP#" - (STRINGIMAGE |$isGenVarCounter|)))) - (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) - (|bfMKPROGN| - (LIST (LIST 'L%T |g| |lhs|) (|bfIS1| |g| |rhs|))))) - ((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|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0#)))))) - (COND - ((EQ |a| 'DOT) - (COND - ((NULL |b|) - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (LIST 'EQ (LIST 'CDR |lhs|) 'NIL)))) - (#1# - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (|bfIS1| (LIST 'CDR |lhs|) |b|)))))) - ((NULL |b|) - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (LIST 'EQ (LIST 'CDR |lhs|) 'NIL) - (|bfIS1| (LIST 'CAR |lhs|) |a|)))) - ((EQ |b| 'DOT) - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (|bfIS1| (LIST 'CAR |lhs|) |a|)))) - (#1# - (PROGN - (SETQ |a1| (|bfIS1| (LIST 'CAR |lhs|) |a|)) - (SETQ |b1| (|bfIS1| (LIST 'CDR |lhs|) |b|)) - (COND - ((AND (CONSP |a1|) (EQ (CAR |a1|) 'PROGN) - (PROGN - (SETQ |ISTMP#1| (CDR |a1|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |c| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (EQUAL (CAR |ISTMP#2|) ''T))))) - (CONSP |b1|) (EQ (CAR |b1|) 'PROGN) - (PROGN (SETQ |cls| (CDR |b1|)) #0#)) - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (|bfMKPROGN| (CONS |c| |cls|))))) - (#1# (|bfAND| (LIST (LIST 'CONSP |lhs|) |a1| |b1|)))))))) - ((AND (CONSP |rhs|) (EQ (CAR |rhs|) 'APPEND) - (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|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |b| (CAR |ISTMP#2|)) #0#)))))) - (PROGN - (SETQ |patrev| (|bfISReverse| |b| |a|)) - (SETQ |g| - (INTERN (CONCAT "ISTMP#" - (STRINGIMAGE |$isGenVarCounter|)))) - (SETQ |$isGenVarCounter| (+ |$isGenVarCounter| 1)) - (SETQ |rev| - (|bfAND| (LIST (LIST 'CONSP |lhs|) - (LIST 'PROGN - (LIST 'L%T |g| - (LIST 'REVERSE |lhs|)) - ''T)))) - (SETQ |l2| (|bfIS1| |g| |patrev|)) - (COND - ((AND (CONSP |l2|) (ATOM (CAR |l2|))) - (SETQ |l2| (CONS |l2| NIL)))) - (COND - ((EQ |a| 'DOT) (|bfAND| (CONS |rev| |l2|))) - (#1# - (|bfAND| (CONS |rev| - (APPEND |l2| - (CONS - (LIST 'PROGN - (|bfLetForm| |a| - (LIST 'NREVERSE |a|)) - ''T) - NIL)))))))) - (#1# - (PROGN - (|bpSpecificErrorHere| "bad IS code is generated") - (|bpTrap|))))))) - -(DEFUN |bfApplication| (|bfop| |bfarg|) - (PROG () - (RETURN - (COND - ((|bfTupleP| |bfarg|) (CONS |bfop| (CDR |bfarg|))) - ('T (CONS |bfop| (LIST |bfarg|))))))) - -(DEFUN |bfGetOldBootName| (|x|) - (PROG (|a|) - (RETURN - (COND ((SETQ |a| (GET |x| 'OLD-BOOT)) (CAR |a|)) ('T |x|))))) - -(DEFUN |bfSameMeaning| (|x|) (PROG () (RETURN (GET |x| 'RENAME-OK)))) - -(DEFUN |bfReName| (|x|) - (PROG (|oldName| |newName| |a|) - (DECLARE (SPECIAL |$translatingOldBoot|)) - (RETURN - (PROGN - (SETQ |newName| - (COND - ((SETQ |a| (GET |x| 'SHOERENAME)) (CAR |a|)) - (#0='T |x|))) - (COND - ((AND |$translatingOldBoot| (NULL (|bfSameMeaning| |x|))) - (PROGN - (SETQ |oldName| (|bfGetOldBootName| |x|)) - (COND - ((NOT (EQUAL |newName| |oldName|)) - (|warn| (LIST (PNAME |x|) " as `" (PNAME |newName|) - "' differs from Old Boot `" - (PNAME |oldName|) "'")))) - |oldName|)) - (#0# |newName|)))))) - -(DEFUN |bfInfApplication| (|op| |left| |right|) - (PROG () - (RETURN - (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|))) - ('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|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0='T)))) - |a|) - ((AND (CONSP |x|) (EQ (CAR |x|) 'NULL) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0#)))) - |a|) - ('T (LIST 'NOT |x|)))))) - -(DEFUN |bfFlatten| (|op| |x|) - (PROG () - (RETURN (COND ((EQCAR |x| |op|) (CDR |x|)) ('T (LIST |x|)))))) - -(DEFUN |bfOR| (|l|) - (PROG () - (RETURN - (COND - ((NULL |l|) NIL) - ((NULL (CDR |l|)) (CAR |l|)) - ('T - (CONS 'OR - (LET ((|bfVar#77| NIL) (|bfVar#76| |l|) (|c| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#76|) - (PROGN (SETQ |c| (CAR |bfVar#76|)) NIL)) - (RETURN (NREVERSE |bfVar#77|))) - ('T - (SETQ |bfVar#77| - (APPEND (REVERSE (|bfFlatten| 'OR |c|)) - |bfVar#77|)))) - (SETQ |bfVar#76| (CDR |bfVar#76|)))))))))) - -(DEFUN |bfAND| (|l|) - (PROG () - (RETURN - (COND - ((NULL |l|) 'T) - ((NULL (CDR |l|)) (CAR |l|)) - ('T - (CONS 'AND - (LET ((|bfVar#79| NIL) (|bfVar#78| |l|) (|c| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#78|) - (PROGN (SETQ |c| (CAR |bfVar#78|)) NIL)) - (RETURN (NREVERSE |bfVar#79|))) - ('T - (SETQ |bfVar#79| - (APPEND (REVERSE (|bfFlatten| 'AND |c|)) - |bfVar#79|)))) - (SETQ |bfVar#78| (CDR |bfVar#78|)))))))))) - -(DEFUN |defQuoteId| (|x|) - (PROG () (RETURN (AND (EQCAR |x| 'QUOTE) (IDENTP (CADR |x|)))))) - -(DEFUN |bfSmintable| (|x|) - (PROG () - (RETURN - (OR (INTEGERP |x|) - (AND (CONSP |x|) (MEMQ (CAR |x|) '(SIZE LENGTH))))))) - -(DEFUN |bfQ| (|l| |r|) - (PROG () - (RETURN - (COND - ((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|)) - ('T (LIST 'EQUAL |l| |r|)))))) - -(DEFUN |bfLessp| (|l| |r|) - (PROG () - (RETURN - (COND ((EQL |r| 0) (LIST 'MINUSP |l|)) ('T (LIST '< |l| |r|)))))) - -(DEFUN |bfMDef| (|defOp| |op| |args| |body|) - (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#82| NIL) (|bfVar#80| |nargl|) (|i| NIL) - (|bfVar#81| |sgargl|) (|j| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#80|) - (PROGN (SETQ |i| (CAR |bfVar#80|)) NIL) - (ATOM |bfVar#81|) - (PROGN (SETQ |j| (CAR |bfVar#81|)) NIL)) - (RETURN (NREVERSE |bfVar#82|))) - (#1='T - (SETQ |bfVar#82| (CONS (CONS |i| |j|) |bfVar#82|)))) - (SETQ |bfVar#80| (CDR |bfVar#80|)) - (SETQ |bfVar#81| (CDR |bfVar#81|))))) - (SETQ |body| (SUBLIS |sb| |body|)) - (SETQ |sb2| - (LET ((|bfVar#85| NIL) (|bfVar#83| |sgargl|) (|i| NIL) - (|bfVar#84| |largl|) (|j| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#83|) - (PROGN (SETQ |i| (CAR |bfVar#83|)) NIL) - (ATOM |bfVar#84|) - (PROGN (SETQ |j| (CAR |bfVar#84|)) NIL)) - (RETURN (NREVERSE |bfVar#85|))) - (#1# - (SETQ |bfVar#85| - (CONS (LIST 'CONS (LIST 'QUOTE |i|) |j|) - |bfVar#85|)))) - (SETQ |bfVar#83| (CDR |bfVar#83|)) - (SETQ |bfVar#84| (CDR |bfVar#84|))))) - (SETQ |body| - (LIST 'SUBLIS (CONS 'LIST |sb2|) (LIST 'QUOTE |body|))) - (SETQ |lamex| (LIST 'MLAMBDA |gargl| |body|)) - (SETQ |def| (LIST |op| |lamex|)) - (|bfTuple| - (CONS (|shoeComp| |def|) - (LET ((|bfVar#87| NIL) (|bfVar#86| |$wheredefs|) - (|d| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#86|) - (PROGN (SETQ |d| (CAR |bfVar#86|)) NIL)) - (RETURN (NREVERSE |bfVar#87|))) - (#1# - (SETQ |bfVar#87| - (APPEND (REVERSE - (|shoeComps| (|bfDef1| |d|))) - |bfVar#87|)))) - (SETQ |bfVar#86| (CDR |bfVar#86|)))))))))) - -(DEFUN |bfGargl| (|argl|) - (PROG (|f| |d| |c| |b| |a| |LETTMP#1|) - (RETURN - (COND - ((NULL |argl|) (LIST NIL NIL NIL NIL)) - (#0='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 (LIST 'QUOTE 'LIST) (CAR |d|)) - (CDR |d|)))) - (#0# (SETQ |f| (|bfGenSymbol|)) - (LIST (CONS |f| |a|) (CONS |f| |b|) (CONS (CAR |argl|) |c|) - (CONS |f| |d|))))))))) - -(DEFUN |bfDef1| (|bfVar#88|) - (PROG (|arglp| |control| |quotes| |LETTMP#1| |argl| |body| |args| - |op| |defOp|) - (RETURN - (PROGN - (SETQ |defOp| (CAR |bfVar#88|)) - (SETQ |op| (CADR . #0=(|bfVar#88|))) - (SETQ |args| (CADDR . #0#)) - (SETQ |body| (CADDDR . #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|))))))))) - -(DEFUN |shoeLAM| (|op| |args| |control| |body|) - (PROG (|innerfunc| |margs|) - (RETURN - (PROGN - (SETQ |margs| (|bfGenSymbol|)) - (SETQ |innerfunc| (INTERN (CONCAT (PNAME |op|) '|,LAM|))) - (LIST (LIST |innerfunc| (LIST 'LAMBDA |args| |body|)) - (LIST |op| - (LIST 'MLAMBDA (LIST '&REST |margs|) - (LIST 'CONS (LIST 'QUOTE |innerfunc|) - (LIST 'WRAP |margs| - (LIST 'QUOTE |control|)))))))))) - -(DEFUN |bfDef| (|defOp| |op| |args| |body|) - (PROG (|body1| |arg1| |op1| |LETTMP#1|) - (DECLARE (SPECIAL |$wheredefs| |$bfClamming|)) - (RETURN - (COND - (|$bfClamming| - (PROGN - (SETQ |LETTMP#1| - (|shoeComp| - (CAR (|bfDef1| - (LIST |defOp| |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#90| NIL) - (|bfVar#89| - (CONS (LIST |defOp| |op| |args| |body|) - |$wheredefs|)) - (|d| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#89|) - (PROGN (SETQ |d| (CAR |bfVar#89|)) NIL)) - (RETURN (NREVERSE |bfVar#90|))) - ('T - (SETQ |bfVar#90| - (APPEND (REVERSE (|shoeComps| (|bfDef1| |d|))) - |bfVar#90|)))) - (SETQ |bfVar#89| (CDR |bfVar#89|)))))))))) - -(DEFUN |shoeComps| (|x|) - (PROG () - (RETURN - (LET ((|bfVar#92| NIL) (|bfVar#91| |x|) (|def| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#91|) - (PROGN (SETQ |def| (CAR |bfVar#91|)) NIL)) - (RETURN (NREVERSE |bfVar#92|))) - ('T (SETQ |bfVar#92| (CONS (|shoeComp| |def|) |bfVar#92|)))) - (SETQ |bfVar#91| (CDR |bfVar#91|))))))) - -(DEFUN |shoeComp| (|x|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| (|shoeCompTran| (CADR |x|))) - (COND - ((EQCAR |a| 'LAMBDA) - (CONS 'DEFUN (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|))))) - ('T - (CONS 'DEFMACRO - (CONS (CAR |x|) (CONS (CADR |a|) (CDDR |a|)))))))))) - -(DEFUN |bfInsertLet| (|x| |body|) - (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|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |a| (CAR |ISTMP#1|)) #0='T)))) - (COND - ((AND (CONSP |a|) (EQ (CAR |a|) 'QUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |a|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |b| (CAR |ISTMP#1|)) #0#)))) - (LIST T 'QUOTE (LIST '&REST |b|) |body|)) - (#1='T (LIST NIL NIL |x| |body|)))) - (#1# (SETQ |LETTMP#1| (|bfInsertLet1| (CAR |x|) |body|)) - (SETQ |b| (CAR |LETTMP#1|)) - (SETQ |norq| (CADR . #2=(|LETTMP#1|))) - (SETQ |name1| (CADDR . #2#)) (SETQ |body1| (CADDDR . #2#)) - (SETQ |LETTMP#1| (|bfInsertLet| (CDR |x|) |body1|)) - (SETQ |b1| (CAR |LETTMP#1|)) - (SETQ |norq1| (CADR . #3=(|LETTMP#1|))) - (SETQ |name2| (CADDR . #3#)) (SETQ |body2| (CADDDR . #3#)) - (LIST (OR |b| |b1|) (CONS |norq| |norq1|) - (CONS |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|) (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) #0='T)))))) - (LIST NIL NIL |l| - (|bfMKPROGN| (LIST (|bfLET| |r| |l|) |body|)))) - ((IDENTP |y|) (LIST NIL NIL |y| |body|)) - ((AND (CONSP |y|) (EQ (CAR |y|) 'BVQUOTE) - (PROGN - (SETQ |ISTMP#1| (CDR |y|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |b| (CAR |ISTMP#1|)) #0#)))) - (LIST T 'QUOTE |b| |body|)) - ('T (SETQ |g| (|bfGenSymbol|)) - (COND - ((ATOM |y|) (LIST NIL NIL |g| |body|)) - ('T - (LIST NIL NIL |g| - (|bfMKPROGN| - (LIST (|bfLET| (|compFluidize| |y|) |g|) |body|)))))))))) - -(DEFUN |shoeCompTran| (|x|) - (PROG (|$dollarVars| |$locVars| |$fluidVars| |fvs| |fl| |fvars| - |lvars| |body| |args| |lamtype|) - (DECLARE (SPECIAL |$typings| |$dollarVars| |$fluidVars| |$locVars|)) - (RETURN - (PROGN - (SETQ |lamtype| (CAR |x|)) - (SETQ |args| (CADR |x|)) - (SETQ |body| (CDDR |x|)) - (SETQ |$fluidVars| NIL) - (SETQ |$locVars| NIL) - (SETQ |$dollarVars| NIL) - (|shoeCompTran1| |body|) - (SETQ |$locVars| - (SETDIFFERENCE (SETDIFFERENCE |$locVars| |$fluidVars|) - (|shoeATOMs| |args|))) - (SETQ |body| - (COND - ((OR |$fluidVars| |$locVars| |$dollarVars| |$typings|) - (SETQ |lvars| (APPEND |$fluidVars| |$locVars|)) - (SETQ |$fluidVars| (UNION |$fluidVars| |$dollarVars|)) - (COND - ((NULL |$fluidVars|) - (COND - ((NULL |$typings|) (|shoePROG| |lvars| |body|)) - (#0='T - (|shoePROG| |lvars| - (CONS (CONS 'DECLARE |$typings|) |body|))))) - (#1='T - (SETQ |fvars| - (LIST 'DECLARE (CONS 'SPECIAL |$fluidVars|))) - (COND - ((NULL |$typings|) - (|shoePROG| |lvars| (CONS |fvars| |body|))) - (#0# - (|shoePROG| |lvars| - (CONS |fvars| - (CONS (CONS 'DECLARE |$typings|) - |body|)))))))) - (#1# (|shoePROG| NIL |body|)))) - (SETQ |fl| (|shoeFluids| |args|)) - (SETQ |body| - (COND - (|fl| (SETQ |fvs| (LIST 'DECLARE (CONS 'SPECIAL |fl|))) - (CONS |fvs| |body|)) - (#1# |body|))) - (CONS |lamtype| (CONS |args| |body|)))))) - -(DEFUN |shoePROG| (|v| |b|) - (PROG (|blist| |blast| |LETTMP#1|) - (RETURN - (COND - ((NULL |b|) (LIST (LIST 'PROG |v|))) - ('T - (PROGN - (SETQ |LETTMP#1| (REVERSE |b|)) - (SETQ |blast| (CAR |LETTMP#1|)) - (SETQ |blist| (NREVERSE (CDR |LETTMP#1|))) - (LIST (CONS 'PROG - (CONS |v| - (APPEND |blist| - (CONS (LIST 'RETURN |blast|) NIL))))))))))) - -(DEFUN |shoeFluids| (|x|) - (PROG () - (RETURN - (COND - ((NULL |x|) NIL) - ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) (LIST |x|)) - ((EQCAR |x| 'QUOTE) NIL) - ((ATOM |x|) NIL) - ('T (APPEND (|shoeFluids| (CAR |x|)) (|shoeFluids| (CDR |x|)))))))) - -(DEFUN |shoeATOMs| (|x|) - (PROG () - (RETURN - (COND - ((NULL |x|) NIL) - ((ATOM |x|) (LIST |x|)) - ('T (APPEND (|shoeATOMs| (CAR |x|)) (|shoeATOMs| (CDR |x|)))))))) - -(DEFUN |shoeCompTran1| (|x|) - (PROG (|res| |newbindings| |r| |ISTMP#2| |l| |ISTMP#1| U) - (DECLARE (SPECIAL |$fluidVars| |$locVars| |$dollarVars|)) - (RETURN - (COND - ((ATOM |x|) - (COND - ((AND (IDENTP |x|) (|bfBeginsDollar| |x|)) - (SETQ |$dollarVars| - (COND - ((MEMQ |x| |$dollarVars|) |$dollarVars|) - (#0='T (CONS |x| |$dollarVars|))))) - (#0# NIL))) - (#0# - (PROGN - (SETQ U (CAR |x|)) - (COND - ((EQ U 'QUOTE) NIL) - ((AND (CONSP |x|) (EQ (CAR |x|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |l| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (EQ (CDR |ISTMP#2|) NIL) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) 'T)))))) - (PROGN - (RPLACA |x| 'SETQ) - (|shoeCompTran1| |r|) - (COND - ((IDENTP |l|) - (COND - ((NULL (|bfBeginsDollar| |l|)) - (SETQ |$locVars| - (COND - ((MEMQ |l| |$locVars|) |$locVars|) - (#0# (CONS |l| |$locVars|))))) - (#0# - (SETQ |$dollarVars| - (COND - ((MEMQ |l| |$dollarVars|) |$dollarVars|) - (#0# (CONS |l| |$dollarVars|))))))) - ((EQCAR |l| 'FLUID) - (PROGN - (SETQ |$fluidVars| - (COND - ((MEMQ (CADR |l|) |$fluidVars|) - |$fluidVars|) - (#0# (CONS (CADR |l|) |$fluidVars|)))) - (RPLACA (CDR |x|) (CADR |l|))))))) - ((MEMQ U '(PROG LAMBDA)) - (PROGN - (SETQ |newbindings| NIL) - (LET ((|bfVar#93| (CADR |x|)) (|y| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#93|) - (PROGN (SETQ |y| (CAR |bfVar#93|)) NIL)) - (RETURN NIL)) - (#1='T - (COND - ((NULL (MEMQ |y| |$locVars|)) - (IDENTITY - (PROGN - (SETQ |$locVars| (CONS |y| |$locVars|)) - (SETQ |newbindings| - (CONS |y| |newbindings|)))))))) - (SETQ |bfVar#93| (CDR |bfVar#93|)))) - (SETQ |res| (|shoeCompTran1| (CDDR |x|))) - (SETQ |$locVars| - (LET ((|bfVar#95| NIL) (|bfVar#94| |$locVars|) - (|y| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#94|) - (PROGN - (SETQ |y| (CAR |bfVar#94|)) - NIL)) - (RETURN (NREVERSE |bfVar#95|))) - (#1# - (AND (NULL (MEMQ |y| |newbindings|)) - (SETQ |bfVar#95| - (CONS |y| |bfVar#95|))))) - (SETQ |bfVar#94| (CDR |bfVar#94|))))))) - (#0# - (PROGN - (|shoeCompTran1| (CAR |x|)) - (|shoeCompTran1| (CDR |x|))))))))))) - -(DEFUN |bfTagged| (|a| |b|) - (PROG () - (DECLARE (SPECIAL |$typings|)) - (RETURN - (COND - ((IDENTP |a|) - (COND - ((EQ |b| 'FLUID) (|bfLET| (|compFluid| |a|) NIL)) - ((EQ |b| '|fluid|) (|bfLET| (|compFluid| |a|) NIL)) - ((EQ |b| '|local|) (|bfLET| (|compFluid| |a|) NIL)) - (#0='T - (PROGN - (SETQ |$typings| (CONS (LIST 'TYPE |b| |a|) |$typings|)) - |a|)))) - (#0# (LIST 'THE |b| |a|)))))) - -(DEFUN |bfAssign| (|l| |r|) - (PROG () - (RETURN - (COND - ((|bfTupleP| |l|) (|bfSetelt| (CADR |l|) (CDDR |l|) |r|)) - ('T (|bfLET| |l| |r|)))))) - -(DEFUN |bfSetelt| (|e| |l| |r|) - (PROG () - (RETURN - (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|)) - (#0='T (LIST |y| |expr|)))) - (#0# (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|)) - (#0='T (LIST 'SETF (LIST |y| |var|) |expr|)))) - (#0# (LIST 'SETF (LIST 'ELT |var| |sel|) |expr|))))))) - -(DEFUN |bfIfThenOnly| (|a| |b|) - (PROG (|b1|) - (RETURN - (PROGN - (SETQ |b1| - (COND ((EQCAR |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 ((EQCAR |b| 'PROGN) (CDR |b|)) (#0='T (LIST |b|)))) - (COND - ((EQCAR |c| 'COND) - (CONS 'COND (CONS (CONS |a| |b1|) (CDR |c|)))) - ('T - (PROGN - (SETQ |c1| - (COND - ((EQCAR |c| 'PROGN) (CDR |c|)) - (#0# (LIST |c|)))) - (LIST 'COND (CONS |a| |b1|) (CONS ''T |c1|))))))))) - -(DEFUN |bfExit| (|a| |b|) - (PROG () (RETURN (LIST 'COND (LIST |a| (LIST 'IDENTITY |b|)))))) - -(DEFUN |bfMKPROGN| (|l|) - (PROG (|a|) - (RETURN - (PROGN - (SETQ |a| - (LET ((|bfVar#96| NIL) (|c| |l|)) - (LOOP - (COND - ((ATOM |c|) (RETURN (NREVERSE |bfVar#96|))) - ('T - (SETQ |bfVar#96| - (APPEND (REVERSE (|bfFlattenSeq| |c|)) - |bfVar#96|)))) - (SETQ |c| (CDR |c|))))) - (COND - ((NULL |a|) NIL) - ((NULL (CDR |a|)) (CAR |a|)) - ('T (CONS 'PROGN |a|))))))) - -(DEFUN |bfFlattenSeq| (|x|) - (PROG (|f|) - (RETURN - (COND - ((NULL |x|) NIL) - (#0='T - (PROGN - (SETQ |f| (CAR |x|)) - (COND - ((ATOM |f|) (COND ((CDR |x|) NIL) ('T (LIST |f|)))) - ((EQCAR |f| 'PROGN) - (COND - ((CDR |x|) - (LET ((|bfVar#98| NIL) (|bfVar#97| (CDR |f|)) - (|i| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#97|) - (PROGN (SETQ |i| (CAR |bfVar#97|)) NIL)) - (RETURN (NREVERSE |bfVar#98|))) - ('T - (AND (NULL (ATOM |i|)) - (SETQ |bfVar#98| (CONS |i| |bfVar#98|))))) - (SETQ |bfVar#97| (CDR |bfVar#97|))))) - (#0# (CDR |f|)))) - (#0# (LIST |f|))))))))) - -(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) - (#0='T - (PROGN - (SETQ |transform| - (LET ((|bfVar#100| NIL) (|bfVar#99| |l|) (|x| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#99|) - (PROGN (SETQ |x| (CAR |bfVar#99|)) NIL) - (NOT (AND (CONSP |x|) (EQ (CAR |x|) 'COND) - (PROGN - (SETQ |ISTMP#1| (CDR |x|)) - (AND (CONSP |ISTMP#1|) - (EQ (CDR |ISTMP#1|) NIL) - (PROGN - (SETQ |ISTMP#2| - (CAR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |a| - (CAR |ISTMP#2|)) - (SETQ |ISTMP#3| - (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CDR |ISTMP#3|) NIL) - (PROGN - (SETQ |ISTMP#4| - (CAR |ISTMP#3|)) - (AND (CONSP |ISTMP#4|) - (EQ (CAR |ISTMP#4|) - 'IDENTITY) - (PROGN - (SETQ |ISTMP#5| - (CDR |ISTMP#4|)) - (AND - (CONSP |ISTMP#5|) - (EQ - (CDR |ISTMP#5|) - NIL) - (PROGN - (SETQ |b| - (CAR |ISTMP#5|)) - 'T)))))))))))))) - (RETURN (NREVERSE |bfVar#100|))) - ('T - (SETQ |bfVar#100| - (CONS (LIST |a| |b|) |bfVar#100|)))) - (SETQ |bfVar#99| (CDR |bfVar#99|))))) - (SETQ |no| (LENGTH |transform|)) - (SETQ |before| (|bfTake| |no| |l|)) - (SETQ |aft| (|bfDrop| |no| |l|)) - (COND - ((NULL |before|) - (COND - ((NULL (CDR |l|)) - (PROGN - (SETQ |f| (CAR |l|)) - (COND - ((EQCAR |f| 'PROGN) (|bfSequence| (CDR |f|))) - ('T |f|)))) - (#0# - (|bfMKPROGN| - (LIST (CAR |l|) (|bfSequence| (CDR |l|))))))) - ((NULL |aft|) (CONS 'COND |transform|)) - (#0# - (CONS 'COND - (APPEND |transform| - (CONS (LIST ''T (|bfSequence| |aft|)) NIL))))))))))) - -(DEFUN |bfWhere| (|context| |expr|) - (PROG (|a| |body| |ISTMP#3| |args| |ISTMP#2| |op| |ISTMP#1| |def| - |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#102| NIL) (|bfVar#101| |defs|) (|d| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#101|) - (PROGN (SETQ |d| (CAR |bfVar#101|)) NIL)) - (RETURN (NREVERSE |bfVar#102|))) - ('T - (AND (CONSP |d|) - (PROGN - (SETQ |def| (CAR |d|)) - (SETQ |ISTMP#1| (CDR |d|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |op| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) - (PROGN - (SETQ |args| (CAR |ISTMP#2|)) - (SETQ |ISTMP#3| (CDR |ISTMP#2|)) - (AND (CONSP |ISTMP#3|) - (EQ (CDR |ISTMP#3|) NIL) - (PROGN - (SETQ |body| (CAR |ISTMP#3|)) - 'T))))))) - (SETQ |bfVar#102| - (CONS (LIST |def| |op| |args| - (|bfSUBLIS| |opassoc| |body|)) - |bfVar#102|))))) - (SETQ |bfVar#101| (CDR |bfVar#101|))))) - (SETQ |$wheredefs| (APPEND |a| |$wheredefs|)) - (|bfMKPROGN| - (|bfSUBLIS| |opassoc| (NCONC |nondefs| (LIST |expr|)))))))) - -(DEFUN |bfReadLisp| (|string|) - (PROG () (RETURN (|bfTuple| (|shoeReadLispString| |string| 0))))) - -(DEFUN |bfCompHash| (|op| |argl| |body|) - (PROG (|computeFunction| |auxfn|) - (RETURN - (PROGN - (SETQ |auxfn| (INTERN (CONCAT (PNAME |op|) ";"))) - (SETQ |computeFunction| - (CONS 'DEFUN (CONS |auxfn| (CONS |argl| |body|)))) - (|bfTuple| (CONS |computeFunction| (|bfMain| |auxfn| |op|))))))) - -(DEFUN |shoeCompileTimeEvaluation| (|x|) - (PROG () (RETURN (LIST 'EVAL-WHEN (LIST :COMPILE-TOPLEVEL) |x|)))) - -(DEFUN |shoeEVALANDFILEACTQ| (|x|) - (PROG () - (RETURN (LIST 'EVAL-WHEN (LIST :EXECUTE :LOAD-TOPLEVEL) |x|)))) - -(DEFUN |bfMain| (|auxfn| |op|) - (PROG (|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 (PNAME |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| - (LIST 'SETQ |cacheName| - (LIST 'MAKE-HASHTABLE (LIST 'QUOTE 'UEQUAL)))) - (SETQ |cacheCountCode| (LIST '|hashCount| |cacheName|)) - (SETQ |cacheVector| - (LIST |op| |cacheName| |cacheType| |cacheResetCode| - |cacheCountCode|)) - (LIST |mainFunction| - (|shoeEVALANDFILEACTQ| - (LIST 'SETF - (LIST 'GET (LIST 'QUOTE |op|) - (LIST 'QUOTE '|cacheInfo|)) - (LIST 'QUOTE |cacheVector|))) - (|shoeEVALANDFILEACTQ| |cacheResetCode|)))))) - -(DEFUN |bfNameOnly| (|x|) - (PROG () (RETURN (COND ((EQ |x| '|t|) (LIST 'T)) ('T (LIST |x|)))))) - -(DEFUN |bfNameArgs| (|x| |y|) - (PROG () - (RETURN - (PROGN - (SETQ |y| - (COND ((EQCAR |y| 'TUPLE) (CDR |y|)) ('T (LIST |y|)))) - (CONS |x| |y|))))) - -(DEFUN |bfStruct| (|name| |arglist|) - (PROG () - (RETURN - (|bfTuple| - (LET ((|bfVar#104| NIL) (|bfVar#103| |arglist|) (|i| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#103|) - (PROGN (SETQ |i| (CAR |bfVar#103|)) NIL)) - (RETURN (NREVERSE |bfVar#104|))) - ('T - (SETQ |bfVar#104| - (CONS (|bfCreateDef| |i|) |bfVar#104|)))) - (SETQ |bfVar#103| (CDR |bfVar#103|)))))))) - -(DEFUN |bfCreateDef| (|x|) - (PROG (|a| |f|) - (RETURN - (COND - ((NULL (CDR |x|)) (SETQ |f| (CAR |x|)) - (LIST 'SETQ |f| (LIST 'LIST (LIST 'QUOTE |f|)))) - ('T - (SETQ |a| - (LET ((|bfVar#106| NIL) (|bfVar#105| (CDR |x|)) - (|i| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#105|) - (PROGN (SETQ |i| (CAR |bfVar#105|)) NIL)) - (RETURN (NREVERSE |bfVar#106|))) - ('T - (SETQ |bfVar#106| - (CONS (|bfGenSymbol|) |bfVar#106|)))) - (SETQ |bfVar#105| (CDR |bfVar#105|))))) - (LIST 'DEFUN (CAR |x|) |a| - (LIST 'CONS (LIST 'QUOTE (CAR |x|)) (CONS 'LIST |a|)))))))) - -(DEFUN |bfCaseItem| (|x| |y|) (PROG () (RETURN (LIST |x| |y|)))) - -(DEFUN |bfCase| (|x| |y|) - (PROG (|c| |b| |a| |g1| |g|) - (RETURN - (PROGN - (SETQ |g| (|bfGenSymbol|)) - (SETQ |g1| (|bfGenSymbol|)) - (SETQ |a| (|bfLET| |g| |x|)) - (SETQ |b| (|bfLET| |g1| (LIST 'CDR |g|))) - (SETQ |c| (|bfCaseItems| |g1| |y|)) - (|bfMKPROGN| - (LIST |a| |b| (CONS 'CASE (CONS (LIST 'CAR |g|) |c|)))))))) - -(DEFUN |bfCaseItems| (|g| |x|) - (PROG (|j| |ISTMP#1| |i|) - (RETURN - (LET ((|bfVar#109| NIL) (|bfVar#108| |x|) (|bfVar#107| NIL)) - (LOOP - (COND - ((OR (ATOM |bfVar#108|) - (PROGN (SETQ |bfVar#107| (CAR |bfVar#108|)) NIL)) - (RETURN (NREVERSE |bfVar#109|))) - ('T - (AND (CONSP |bfVar#107|) - (PROGN - (SETQ |i| (CAR |bfVar#107|)) - (SETQ |ISTMP#1| (CDR |bfVar#107|)) - (AND (CONSP |ISTMP#1|) (EQ (CDR |ISTMP#1|) NIL) - (PROGN (SETQ |j| (CAR |ISTMP#1|)) 'T))) - (SETQ |bfVar#109| - (CONS (|bfCI| |g| |i| |j|) |bfVar#109|))))) - (SETQ |bfVar#108| (CDR |bfVar#108|))))))) - -(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#111| NIL) (|bfVar#110| |a|) (|i| NIL) - (|j| 0)) - (LOOP - (COND - ((OR (ATOM |bfVar#110|) - (PROGN (SETQ |i| (CAR |bfVar#110|)) NIL)) - (RETURN (NREVERSE |bfVar#111|))) - ('T - (SETQ |bfVar#111| - (CONS (LIST |i| (|bfCARCDR| |j| |g|)) - |bfVar#111|)))) - (SETQ |bfVar#110| (CDR |bfVar#110|)) - (SETQ |j| (+ |j| 1))))) - (LIST (CAR |x|) (LIST 'LET |b| |y|)))))))) - -(DEFUN |bfCARCDR| (|n| |g|) - (PROG () - (RETURN (LIST (INTERN (CONCAT "CA" (|bfDs| |n|) "R")) |g|)))) - -(DEFUN |bfDs| (|n|) - (PROG () - (RETURN - (COND ((EQL |n| 0) "") ('T (CONCAT "D" (|bfDs| (- |n| 1)))))))) - -@ - -\end{document} -- cgit v1.2.3