-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2008, Gabriel Dos Reis.
-- 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.
--
--
-- Abstract:
-- This file defines the AST data structure and helper functions
-- for representing Boot programs.
--
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
--% Basic types used in Boot codes.
%Thing <=> true
%Boolean <=> BOOLEAN
%String <=> STRING
%Symbol <=> SYMBOL
%Short <=> FIXNUM
++ Ideally, we would like to say that a List T if either nil or a
++ cons of a T and List of T.
%List <=> LIST
%Vector <=> VECTOR
%Sequence <=> SEQUENCE
++ 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 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(%Head, %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
%DefaultValue(%Name,%Ast) -- opt. value for function param.
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
%Throw(Ast) -- throw OutOfRange 3
%Catch(Ast) -- catch OutOfRange
%Try(Ast,%Sequence) -- try x / y catch DivisionByZero
Where(Ast,%Sequence) -- e where f x == y
Structure(Ast,%Sequence) -- structure Foo == ...
-- TRUE if we are currently building the syntax tree for an 'is'
-- expression.
$inDefIS := false
++ returns a `quote' ast for x.
quote x ==
["QUOTE",x]
--%
bfGenSymbol: () -> %Symbol
bfGenSymbol()==
$GenVarCounter:=$GenVarCounter+1
INTERN(CONCAT ('"bfVar#",STRINGIMAGE $GenVarCounter))
bfListOf: %List -> %List
bfListOf x==x
bfColon: %Thing -> %List
bfColon x== ["COLON",x]
bfColonColon: (%Symbol,%Symbol) -> %Symbol
bfColonColon(package, name) ==
%hasFeature KEYWORD::CLISP and package in '(EXT FFI) =>
FIND_-SYMBOL(SYMBOL_-NAME name,package)
INTERN(SYMBOL_-NAME name, package)
bfSymbol: %Thing -> %Thing
bfSymbol x==
STRINGP x=> x
['QUOTE,x]
bfDot: () -> %Symbol
bfDot() ==
"DOT"
bfSuffixDot: %Thing -> %List
bfSuffixDot x ==
[x,"DOT"]
bfEqual: %Thing -> %List
bfEqual(name) ==
["EQUAL",name]
bfBracket: %Thing -> %Thing
bfBracket(part) ==
part
bfPile: %List -> %List
bfPile(part) ==
part
bfAppend: %List -> %List
bfAppend x==
APPLY(function APPEND,x)
bfColonAppend: (%List,%Thing) -> %List
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: (%Thing,%Thing,%Thing) -> %List
bfDefinition(bflhsitems, bfrhs,body) ==
['DEF,bflhsitems,bfrhs,body]
bfMDefinition: (%Thing,%Thing,%Thing) -> %List
bfMDefinition(bflhsitems, bfrhs,body) ==
bfMDef('MDEF,bflhsitems,bfrhs,body)
bfCompDef: %Thing -> %List
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: %Thing -> %Boolean
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")
++ If `bf' is a tuple return its elements; otherwise `bf'.
bfUntuple bf ==
bfTupleP bf => cdr bf
bf
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]
++ Translate function parameter list to Lisp.
++ We are processing a function definition. `p2' is the list of
++ parameters we have seen so far, and we are about to add a
++ parameter `p1'. Check that the new specification is coherent
++ with the previous one. In particular, check that restrictions
++ on parameters with default values are satisfied. Return the
++ new augmented parameter list.
bfParameterList(p1,p2) ==
p2=nil and not atom p1 => p1
p1 is ["&OPTIONAL",:.] =>
p2 isnt ["&OPTIONAL",:.] => bpSpecificErrorHere '"default value required"
[first p1,:rest p1,:rest p2]
p2 is ["&OPTIONAL",:.] => [p1,first p2,:rest p2]
[p1,:p2]
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),bfParameterList(name1,name2),body2]
bfInsertLet1(y,body)==
y is ["L%T",l,r] => [false,nil,l,bfMKPROGN [bfLET(r,l),body]]
IDENTP y => [false,nil,y,body]
y is ["BVQUOTE",b] => [true,"QUOTE",b,body]
g:=bfGenSymbol()
ATOM y => [false,nil,g,body]
case y of
%DefaultValue(p,v) => [false,nil,["&OPTIONAL",[p,v]],body]
otherwise => [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:=
lvars:=append($fluidVars,$locVars)
$fluidVars:=UNION($fluidVars,$dollarVars)
body' := body
if $typings then body' := [["DECLARE",:$typings],:body']
if $fluidVars then
fvars:=["DECLARE",["SPECIAL",:$fluidVars]]
body' := [fvars,:body']
if lvars or needsPROG body then shoePROG(lvars,body') else body'
fl:=shoeFluids args
body:=if fl
then
fvs:=["DECLARE",["SPECIAL",:fl]]
cons(fvs,body)
else body
[lamtype,args, :body]
needsPROG body ==
atom body => false
[op,:args] := body
op in '(RETURN RETURN_-FROM) => true
op in '(LET PROG LOOP BLOCK DECLARE LAMBDA) => false
or/[needsPROG t for t in body] => true
false
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)==
null $op => Signature(a,b) -- surely a toplevel decl
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]
defCode := ["DEFPARAMETER",cacheName,
['MAKE_-HASHTABLE,["QUOTE","UEQUAL"]]]
[defCode,mainFunction,
shoeEVALANDFILEACTQ
["SETF",["GET",
["QUOTE", op],["QUOTE",'cacheInfo]],["QUOTE", cacheVector]]]
bfNameOnly: %Thing -> %List
bfNameOnly x==
if x="t"
then ["T"]
else [x]
bfNameArgs: (%Thing,%Thing) -> %List
bfNameArgs (x,y)==
y:=if EQCAR(y,"TUPLE") then CDR y else [y]
cons(x,y)
bfStruct: (%Thing,%List) -> %List
bfStruct(name,arglist)==
bfTuple [bfCreateDef i for i in arglist]
bfCreateDef: %Thing -> %List
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: (%Thing,%Thing) -> %List
bfCaseItem(x,y) ==
[x,y]
bfCase: (%Thing,%Thing) -> %List
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: (%Thing,%List) -> %List
bfCaseItems(g,x) ==
[bfCI(g,i,j) for [i,j] in x]
bfCI: (%Thing,%Thing,%Thing) -> %List
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: (%Short,%Thing) -> %List
bfCARCDR(n,g) ==
[INTERN CONCAT ('"CA",bfDs n,'"R"),g]
bfDs: %Short -> %String
bfDs n==
if n=0 then '"" else CONCAT('"D",bfDs(n-1))
++ Generate code for try-catch expressions.
bfTry: (%Thing,%List) -> %Thing
bfTry(e,cs) ==
null cs => e
case first cs of
%Catch(tag) =>
atom tag => bfTry(["CATCH",["QUOTE",tag],e],rest cs)
bpTrap() -- sorry
otherwise => bpTrap()
++ Generate code for `throw'-expressions
bfThrow e ==
atom e => ["THROW",["QUOTE",e],nil]
not atom first e => bpTrap()
["THROW",["QUOTE",first e],:rest e]
--% Type alias definition
backquote(form,params) ==
null params => quote form
atom form =>
form in params => form
quote form
["LIST",:[backquote(t,params) for t in form]]
genTypeAlias(head,body) ==
[op,:args] := head
["DEFTYPE",op,args,backquote(body,args)]
--% Native datatype translation
coreSymbol: %Symbol -> %Symbol
coreSymbol s ==
INTERN(SYMBOL_-NAME s, "AxiomCore")
bootSymbol: %Symbol -> %Symbol
bootSymbol s ==
INTERN SYMBOL_-NAME s
nativeType t ==
null t => t
t' := ASSOC(coreSymbol t,$NativeTypeTable) => bootSymbol rest t'
fatalError CONCAT('"unsupported native type: ", SYMBOL_-NAME t)