-- Copyright (c) 1991-2002, The Numerical Algorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2011, 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. -- import includer namespace BOOTTRAN module ast ++ 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 ++ List of identifiers defined as constants in the current ++ translation unit. $constantIdentifiers := nil ++ When non-nil holds the scope nominated in the most recent ++ namespace definition. $activeNamespace := nil structure %Ast == %Command(%String) -- includer command %Lisp(%String) -- )lisp command %Module(%Symbol,%List,%List) -- module declaration %Namespace(%Symbol) -- namespace AxiomCore %Import(%Ast) -- import module; import namespace foo %ImportSignature(%Symbol,%Signature) -- import function declaration %TypeAlias(%Head, %List) -- type alias definition %Signature(%Symbol,%Mapping) -- op: S -> T %Mapping(%Ast, %List) -- (S1, S2) -> T %Forall(%List,%Ast) -- forall a . a -> a %SuffixDot(%Ast) -- x . %Quote(%Ast) -- 'x %EqualPattern(%Ast) -- =x -- patterns %Colon(%Symbol) -- :x %QualifiedName(%Symbol,%Symbol) -- m::x %DefaultValue(%Symbol,%Ast) -- opt. value for function param. %Bracket(%Ast) -- [x, y] %UnboundedSegment(%Ast) -- 3.. %BoundedSgement(%Ast,%Ast) -- 2..4 %Tuple(%List) -- a, b, c, d %ColonAppend(%Ast,%Ast) -- [:y] or [x, :y] %Pretend(%Ast,%Ast) -- e : t -- hard coercion %Is(%Ast,%Ast) -- e is p -- patterns %Isnt(%Ast,%Ast) -- e isnt p -- patterns %Reduce(%Ast,%Ast) -- +/[...] %PrefixExpr(%Symbol,%Ast) -- #v %Call(%Ast,%Sequence) -- f(x, y , z) %InfixExpr(%Symbol,%Ast,%Ast) -- x + y %ConstantDefinition(%Symbol,%Ast) -- x == y %Definition(%Symbol,%Ast,%Ast) -- f x == y %Macro(%Symbol,%List,%Ast) -- m x ==> y %Lambda(%List,%Ast) -- x +-> x**2 %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 %Implies(%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 %Leave(%Ast) -- leave x %Throw(%Ast) -- throw OutOfRange 3 %Catch(%Signature,%Ast) -- catch(x: OutOfRange) => print x %Finally(%Ast) -- finally closeStream f %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 makeSymbol strconc('"bfVar#",toString $GenVarCounter) bfLetVar: () -> %Symbol bfLetVar() == $letGenVarCounter := $letGenVarCounter + 1 makeSymbol strconc('"LETTMP#",toString $letGenVarCounter) bfIsVar: () -> %Symbol bfIsVar() == $isGenVarCounter := $isGenVarCounter + 1 makeSymbol strconc('"ISTMP#",toString $isGenVarCounter) bfColon: %Thing -> %Form bfColon x== ["COLON",x] bfColonColon: (%Symbol,%Symbol) -> %Symbol bfColonColon(package, name) == %hasFeature KEYWORD::CLISP and package in '(EXT FFI) => FIND_-SYMBOL(symbolName name,package) makeSymbol(symbolName name, package) bfSymbol: %Thing -> %Thing bfSymbol x== string? x=> x ['QUOTE,x] bfDot: () -> %Symbol bfDot() == "DOT" bfSuffixDot: %Form -> %Form bfSuffixDot x == [x,"DOT"] bfEqual: %Form -> %Form bfEqual(name) == ["EQUAL",name] bfBracket: %Thing -> %Thing bfBracket(part) == part bfPile: %List %Form -> %List %Form bfPile(part) == part bfDo x == x bfAtScope(s,x) == ["LET",[["*PACKAGE*",s]],x] bfAppend: %List %List %Form -> %List %Form bfAppend ls == ls isnt [l,:ls] => nil r := copyList l p := r repeat ls isnt [l,:ls] => return r l = nil => nil lastNode(p).rest := copyList l p := rest p bfColonAppend: (%List %Form,%Form) -> %Form bfColonAppend(x,y) == x = nil => y is ["BVQUOTE",:a] => ["&REST",["QUOTE",:a]] ["&REST",y] [first x,:bfColonAppend(rest x,y)] bfBeginsDollar: %Thing -> %Boolean bfBeginsDollar x == stringChar(symbolName x,0) = char "$" compFluid id == ["FLUID",id] compFluidize x== x = nil => nil symbol? x and bfBeginsDollar x => compFluid x atomic? x => x [compFluidize(first x),:compFluidize(rest x)] bfPlace x == ["%Place",:x] bfTuple x == ["TUPLE",:x] bfTupleP x == x is ["TUPLE",:.] ++ If `bf' is a tuple return its elements; otherwise `bf'. bfUntuple bf == bfTupleP bf => rest bf bf bfTupleIf x== bfTupleP x => x bfTuple x bfTupleConstruct b == a := bfTupleP b => rest b [b] or/[x is ["COLON",.] for x in a] => bfMakeCons a ["LIST",:a] bfConstruct b == a := bfTupleP b => rest b [b] bfMakeCons a bfMakeCons l == l = nil => nil l is [["COLON",a],:l1] => l1 => ['append,a,bfMakeCons l1] a ['CONS,first l,bfMakeCons rest l] bfFor(bflhs,U,step) == U is ["tails",:.] => bfForTree('ON, bflhs, second U) U is ["SEGMENT",:.] => bfSTEP(bflhs,second U,step,third U) bfForTree('IN, bflhs, U) bfForTree(OP,lhs,whole)== whole := bfTupleP whole => bfMakeCons rest whole whole atom lhs => bfINON [OP,lhs,whole] lhs := bfTupleP lhs => second lhs lhs lhs is ["L%T",:.] => G := second lhs [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,third lhs)] G := bfGenSymbol() [:bfINON [OP,G,whole],:bfSuchthat bfIS(G,lhs)] bfSTEP(id,fst,step,lst)== initvar := [id] initval := [fst] inc := atom step => step g1 := bfGenSymbol() initvar := [g1,:initvar] initval := [step,:initval] g1 final := atom lst => lst g2 := bfGenSymbol() initvar := [g2,:initvar] initval := [lst,:initval] g2 ex := lst = nil => [] integer? inc => pred := inc < 0 => "<" ">" [[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 op is "ON" => bfON(id,whole) bfIN(id,whole) bfIN(x,E)== g := bfGenSymbol() vars := [g] inits := [E] exitCond := ['ATOM,g] if x isnt "DOT" then vars := [:vars,x] inits := [:inits,nil] exitCond := ['OR,exitCond,['PROGN,['SETQ,x,['CAR,g]] ,'NIL]] [[vars,inits,[['SETQ,g,['CDR, g]]],[],[exitCond],[]]] bfON(x,E)== if x is "DOT" then x := bfGenSymbol() -- allow a list variable to iterate over its own tails. var := init := nil if not symbol? E or not symbolEq?(x,E) then var := [x] init := [E] [[var,init,[['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)== iters is ["ITERATORS",:.] => bfLp1(rest iters,body) bfLpCross(rest iters,body) bfLpCross(iters,body)== rest iters = nil => bfLp(first iters,body) bfLp(first iters,bfLpCross(rest iters,body)) bfSep(iters)== iters = nil => [[],[],[],[],[],[]] f := first iters r := bfSep rest iters [append(i,j) for i in f for j in r] bfReduce(op,y)== a := op is ["QUOTE",:.] => second op op op := bfReName a init := a has SHOETHETA or op has SHOETHETA g := bfGenSymbol() g1 := bfGenSymbol() body := ['SETQ,g,[op,g,g1]] init = nil => g2 := bfGenSymbol() init := ['CAR,g2] ny := ['CDR,g2] it := ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,ny)]] bfMKPROGN [['L%T,g2,y],bfLp(it,body)] init := first init it := ["ITERATORS",:[[[[g],[init],[],[],[],[g]]],bfIN(g1,y)]] bfLp(it,body) bfReduceCollect(op,y)== y is ["COLLECT",:.] => body := second y itl := third y a := op is ["QUOTE",:.] => second op op a is "append!" => bfDoCollect(body,itl,'lastNode,'skipNil) a is "append" => bfDoCollect(['copyList,body],itl,'lastNode,'skipNil) op := bfReName a init := a has SHOETHETA or op has SHOETHETA bfOpReduce(op,init,body,itl) seq := y = nil => bfTuple nil second y bfReduce(op,bfTupleConstruct seq) -- delayed collect bfDCollect(y,itl) == ["COLLECT",y,itl] bfDTuple x == ["DTUPLE",x] bfCollect(y,itl) == y is ["COLON",a] => a is ['CONS,:.] or a is ['LIST,:.] => bfDoCollect(a,itl,'lastNode,'skipNil) bfDoCollect(['copyList,a],itl,'lastNode,'skipNil) y is ["TUPLE",:.] => bfDoCollect(bfConstruct y,itl,'lastNode,'skipNil) bfDoCollect(['CONS,y,'NIL],itl,'CDR,nil) bfMakeCollectInsn(expr,prev,head,adv) == firstTime := bfMKPROGN [['SETQ,head,expr],['SETQ,prev,(adv is 'CDR => head; [adv,head])]] otherTime := bfMKPROGN [['RPLACD,prev,expr],['SETQ,prev,[adv,prev]]] bfIf(['NULL,head],firstTime,otherTime) bfDoCollect(expr,itl,adv,k) == head := bfGenSymbol() -- pointer to the result prev := bfGenSymbol() -- pointer to the previous cell body := k is 'skipNil => x := bfGenSymbol() ['LET,[[x,expr]], bfIf(['NULL,x],'NIL,bfMakeCollectInsn(x,prev,head,adv))] bfMakeCollectInsn(expr,prev,head,adv) extrait := [[[head,prev],['NIL,'NIL],nil,nil,nil,[head]]] bfLp2(extrait,itl,body) bfLp1(iters,body)== [vars,inits,sucs,filters,exits,value] := bfSep bfAppend iters nbody := filters = nil => body bfAND [:filters,body] value := value = nil => "NIL" first value exits := exits = nil => nbody bfIf(bfOR exits,["RETURN",value],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)== itl is ["ITERATORS",:.] => bfLp1([extrait,:rest itl],body) iters := rest itl bfLpCross([["ITERATORS",extrait,:CDAR iters],:rest iters],body) bfOpReduce(op,init,y,itl)== g := bfGenSymbol() body:= op is "AND" => bfMKPROGN [["SETQ",g,y], ['COND, [['NOT,g],['RETURN,'NIL]]]] op is "OR" => bfMKPROGN [["SETQ",g,y], ['COND, [g,['RETURN,g]]]] ['SETQ,g,[op,g,y]] init = nil => g1 := bfGenSymbol() init := ['CAR,g1] y := ['CDR,g1] -- ??? bogus self-assignment/initialization extrait := [[[g],[init],[],[],[],[g]]] bfMKPROGN [['L%T,g1,y],bfLp2(extrait,itl,body)] init := first 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)== b is "FLUID" => compFluid a b is "local" => compFluid a a bfTake(n,x)== x = nil => x n=0 => nil [first x,:bfTake(n-1,rest x)] bfDrop(n,x)== x = nil or n = 0 => x bfDrop(n-1,rest x) bfReturnNoName a == ["RETURN",a] bfLeave x == ["%Leave",x] bfSUBLIS(p,e)== atom e => bfSUBLIS1(p,e) e.op is 'QUOTE => e [bfSUBLIS(p,first e),:bfSUBLIS(p,rest 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)== p = nil => e f := first p sameObject?(first f,e) => bfSUBLIS(p, rest f) bfSUBLIS1(rest p,e) defSheepAndGoats(x)== case x of %Definition(op,args,body) => argl := bfTupleP args => rest args [args] argl = nil => opassoc := [[op,:body]] [opassoc,[],[]] op1 := makeSymbol strconc(symbolName $op,'",",symbolName op) opassoc := [[op,:op1]] defstack := [[op1,args,body]] [opassoc,defstack,[]] %Pile defs => defSheepAndGoatsList defs otherwise => [[],[],[x]] defSheepAndGoatsList(x)== x = nil => [[],[],[]] [opassoc,defs,nondefs] := defSheepAndGoats first x [opassoc1,defs1,nondefs1] := defSheepAndGoatsList rest x [append(opassoc,opassoc1),append(defs,defs1), append(nondefs,nondefs1)] --% LET bfLetForm(lhs,rhs) == ['L%T,lhs,rhs] bfLET1(lhs,rhs) == symbol? lhs => bfLetForm(lhs,rhs) lhs is ['FLUID,.] => bfLetForm(lhs,rhs) symbol? rhs and not bfCONTAINED(rhs,lhs) => rhs1 := bfLET2(lhs,rhs) rhs1 is ["L%T",:.] => bfMKPROGN [rhs1,rhs] rhs1 is ["PROGN",:.] => [:rhs1,:[rhs]] if symbol? first rhs1 then rhs1 := [rhs1,:nil] bfMKPROGN [:rhs1,rhs] rhs is ["L%T",:.] and symbol?(name := second rhs) => -- handle things like [a] := x := foo l1 := bfLET1(name,third rhs) l2 := bfLET1(lhs,name) l2 is ["PROGN",:.] => bfMKPROGN [l1,:rest l2] if symbol? first l2 then l2 := [l2,:nil] bfMKPROGN [l1,:l2,name] g := bfLetVar() rhs1 := ['L%T,g,rhs] let1 := bfLET1(lhs,g) let1 is ["PROGN",:.] => bfMKPROGN [rhs1,:rest let1] if symbol? first let1 then let1 := [let1,:nil] bfMKPROGN [rhs1,:let1,g] bfCONTAINED(x,y)== sameObject?(x,y) => true atom y=> false bfCONTAINED(x,first y) or bfCONTAINED(x,rest y) bfLET2(lhs,rhs) == lhs = nil => nil symbol? lhs => bfLetForm(lhs,rhs) lhs is ['FLUID,.] => bfLetForm(lhs,rhs) lhs is ['L%T,a,b] => a := bfLET2(a,rhs) (b := bfLET2(b,rhs)) = nil => a atom b => [a,b] cons? first b => [a,:b] [a,b] lhs is ['CONS,var1,var2] => var1 is "DOT" or var1 is ["QUOTE",:.] => bfLET2(var2,addCARorCDR('CDR,rhs)) l1 := bfLET2(var1,addCARorCDR('CAR,rhs)) var2 = nil or var2 is "DOT" =>l1 if cons? l1 and atom first l1 then l1 := [l1,:nil] symbol? var2 => [:l1,bfLetForm(var2,addCARorCDR('CDR,rhs))] l2 := bfLET2(var2,addCARorCDR('CDR,rhs)) if cons? l2 and atom first l2 then l2 := [l2,:nil] [:l1,:l2] lhs is ['append,var1,var2] => patrev := bfISReverse(var2,var1) rev := ['reverse,rhs] g := bfLetVar() l2 := bfLET2(patrev,g) if cons? l2 and atom first l2 then l2 := [l2,:nil] var1 is "DOT" => [['L%T,g,rev],:l2] first lastNode l2 is ['L%T, =var1, val1] => [['L%T,g,rev],:reverse rest reverse l2, bfLetForm(var1,['reverse!,val1])] [['L%T,g,rev],:l2,bfLetForm(var1,['reverse!,var1])] lhs is ["EQUAL",var1] => ['COND,[bfQ(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 := 0 bfLET1(lhs,rhs) addCARorCDR(acc,expr) == atom expr => [acc,expr] acc is 'CAR and expr is ["reverse",:.] => ["CAR",["lastNode",:rest expr]] funs := '(CAR CDR CAAR CDAR CADR CDDR CAAAR CADAR CAADR CADDR CDAAR CDDAR CDADR CDDDR) p := bfPosition(first 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) acc is 'CAR => [funsA.p,:rest expr] [funsR.p,:rest expr] bfPosition(x,l) == bfPosn(x,l,0) bfPosn(x,l,n) == l = nil => -1 x = first l => n bfPosn(x,rest l,n+1) --% IS bfISApplication(op,left,right)== op is "IS" => bfIS(left,right) op is "ISNT" => bfNOT bfIS(left,right) [op ,left,right] bfIS(left,right)== $isGenVarCounter: local := 0 $inDefIS: local :=true bfIS1(left,right) bfISReverse(x,a) == x is ['CONS,:.] => third x = nil => ['CONS,second x, a] y := bfISReverse(third x, nil) y.rest.rest.first := ['CONS,second x,a] y bpSpecificErrorHere '"Error in bfISReverse" bpTrap() bfIS1(lhs,rhs) == rhs = nil => ['NULL,lhs] bfString? rhs => bfAND [['STRINGP,lhs],["STRING=",lhs,rhs]] bfChar? rhs or integer? rhs => ['EQL,lhs,rhs] atom rhs => ['PROGN,bfLetForm(rhs,lhs),'T] rhs is ['QUOTE,a] => symbol? a => ['EQ,lhs,rhs] string? a => bfAND [['STRINGP,lhs],["STRING=",lhs,a]] ["EQUAL",lhs,rhs] rhs is ['L%T,c,d] => l := bfLET(c,lhs) bfAND [bfIS1(lhs,d),bfMKPROGN [l,'T]] rhs is ["EQUAL",a] => bfQ(lhs,a) cons? lhs => g := bfIsVar() bfMKPROGN [['L%T,g,lhs],bfIS1(g,rhs)] rhs is ['CONS,a,b] => a is "DOT" => b = nil => bfAND [['CONSP,lhs],['NULL,['CDR,lhs]]] b is "DOT" => ['CONSP,lhs] bfAND [['CONSP,lhs],bfIS1(['CDR,lhs],b)] b = nil => bfAND [['CONSP,lhs],['NULL,['CDR,lhs]],bfIS1(['CAR,lhs],a)] b is "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 := bfIsVar() rev := bfAND [['CONSP,lhs],['PROGN,['L%T,g,['reverse,lhs]],'T]] l2 := bfIS1(g,patrev) if cons? l2 and atom first l2 then l2 := [l2,:nil] a is "DOT" => bfAND [rev,:l2] bfAND [rev,:l2,['PROGN,bfLetForm(a,['reverse!,a]),'T]] bpSpecificErrorHere '"bad IS code is generated" bpTrap() bfHas(expr,prop) == symbol? prop => ["GET",expr,["QUOTE",prop]] bpSpecificErrorHere('"expected identifier as property name") bfApplication(bfop, bfarg) == bfTupleP bfarg => [bfop,:rest bfarg] [bfop,bfarg] -- returns the meaning of x in the appropriate Boot dialect. bfReName x== a := x has SHOERENAME => first a x sequence?(x,pred) == x is ["QUOTE",seq] and cons? seq and "and"/[apply(pred,y,nil) for y in seq] idList? x == x is ["LIST",:.] and "and"/[defQuoteId arg for arg in x.args] charList? x == x is ["LIST",:.] and "and"/[bfChar? arg for arg in x.args] stringList? x == x is ["LIST",:.] and "and"/[bfString? arg for arg in x.args] ++ Generate code for a membership test `x in seq' where `seq' ++ is a sequence (e.g. a list) bfMember(var,seq) == integer? var or sequence?(seq,function integer?) => seq is ["QUOTE",[x]] => ["EQL",var,x] ["scalarMember?",var,seq] defQuoteId var or sequence?(seq,function symbol?) => seq is ["QUOTE",[x]] => ["EQ",var,["QUOTE",x]] ["symbolMember?",var,seq] idList? seq => seq.args is [.] => ["EQ",var,:seq.args] symbol? var and seq.args is [x,y] => bfOR [["EQ",var,x],["EQ",var,y]] ["symbolMember?",var,seq] bfChar? var or sequence?(seq,function char?) => seq is ["QUOTE",[x]] => ["CHAR=",var,x] ["charMember?",var,seq] charList? seq => seq.args is [.] => ["CHAR=",var,:seq.args] symbol? var and seq.args is [x,y] => bfOR [["CHAR=",var,x],["CHAR=",var,y]] ["charMember?",var,seq] bfString? var or sequence?(seq,function string?) => seq is ["QUOTE",[x]] => ["STRING=",var,x] ["stringMember?",var,seq] stringList? seq => seq.args is [.] => ["STRING=",var,:seq.args] symbol? var and seq.args is [x,y] => bfOR [["STRING=",var,x],["STRING=",var,y]] ["stringMember?",var,seq] ["MEMBER",var,seq] bfInfApplication(op,left,right)== op is "EQUAL" => bfQ(left,right) op is "/=" => bfNOT bfQ(left,right) op is ">" => bfLessp(right,left) op is "<" => bfLessp(left,right) op is "<=" => bfNOT bfLessp(right,left) op is ">=" => bfNOT bfLessp(left,right) op is "OR" => bfOR [left,right] op is "AND" => bfAND [left,right] op is "IN" => bfMember(left,right) [op,left,right] bfNOT x== x is ["NOT",a]=> a x is ["NULL",a]=> a ["NOT",x] bfFlatten(op, x) == x is [=op,:.] => rest x [x] bfOR l == l = nil => false rest l = nil => first l ["OR",:[:bfFlatten("OR",c) for c in l]] bfAND l == l = nil => true rest l = nil => first l ["AND",:[:bfFlatten("AND",c) for c in l]] defQuoteId x== x is ["QUOTE",:.] and symbol? second x bfChar? x == char? x or cons? x and x.op in '(char CODE_-CHAR SCHAR) bfSmintable x== integer? x or cons? x and x.op in '(SIZE LENGTH CHAR_-CODE MAXINDEX _+ _-) bfString? x == string? x or cons? x and first x in '(STRING SYMBOL_-NAME subString) bfQ(l,r)== bfChar? l or bfChar? r => ["CHAR=",l,r] bfSmintable l or bfSmintable r => ["EQL",l,r] defQuoteId l or defQuoteId r => ["EQ",l,r] l = nil => ["NULL",r] r = nil => ["NULL",l] l = true or r = true => ["EQ",l,r] bfString? l or bfString? r => ["STRING=",l,r] l is "%nothing" or r is "%nothing" => ["EQ",l,r] ["EQUAL",l,r] bfLessp(l,r)== l = 0 => ["PLUSP",r] r = 0 => ["MINUSP", l] bfChar? l or bfChar? r => ["CHAR<",l,r] bfString? l or bfString? r => ["STRING<",l,r] ["<",l,r] bfLambda(vars,body) == -- FIXME: Check that we have only names in vars. vars := bfTupleP vars => rest vars [vars] ["LAMBDA",vars,body] bfMDef (op,args,body) == argl := bfTupleP args => rest args [args] [gargl,sgargl,nargl,largl]:=bfGargl argl sb := [[i,:j] for i in nargl for j in sgargl] body := applySubst(sb,body) sb2 := [["CONS",["QUOTE",i],j] for i in sgargl for j in largl] body := ["applySubst",["LIST",:sb2],["QUOTE",body]] lamex:= ["MLAMBDA",gargl,body] def:= [op,lamex] [shoeComp def,:[:shoeComps bfDef1 d for d in $wheredefs]] bfGargl argl== argl = nil => [[],[],[],[]] [a,b,c,d] := bfGargl rest argl first argl is "&REST" => [[first argl,:b],b,c, [["CONS",["QUOTE","LIST"],first d],:rest d]] f := bfGenSymbol() [[f,:a],[f,:b],[first argl,:c],[f,:d]] bfDef1 [op,args,body] == argl := bfTupleP args => rest args [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:= makeSymbol strconc(symbolName op,'",LAM") [[innerfunc,["LAMBDA",args,body]], [op,["MLAMBDA",["&REST",margs],["CONS",["QUOTE", innerfunc], ["WRAP",margs, ["QUOTE", control]]]]]] bfDef(op,args,body) == $bfClamming => [.,op1,arg1,:body1] := shoeComp first bfDef1 [op,args,body] bfCompHash(op1,arg1,body1) bfTuple [:shoeComps bfDef1 d for d in [[op,args,body],:$wheredefs]] shoeComps x== [shoeComp def for def in x] shoeComp x== a := shoeCompTran second x a is ["LAMBDA",:.] => ["DEFUN",first x,second a,:CDDR a] ["DEFMACRO",first x,second 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)== x = nil => [false,nil,x,body] x is ["&REST",a] => a is ["QUOTE",b] => [true,"QUOTE",["&REST",b],body] [false,nil,x,body] [b,norq,name1,body1] := bfInsertLet1 (first x,body) [b1,norq1,name2,body2] := bfInsertLet (rest x,body1) [b or b1,[norq,:norq1],bfParameterList(name1,name2),body2] bfInsertLet1(y,body)== y is ["L%T",l,r] => [false,nil,l,bfMKPROGN [bfLET(r,l),body]] symbol? 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,args,:body] := 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'] lvars or needsPROG body => shoePROG(lvars,body') body' fl := shoeFluids args body := fl => fvs:=["DECLARE",["SPECIAL",:fl]] [fvs,:body] 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] shoePROG(v,b)== b = nil => [["PROG", v]] [:blist,blast] := b [["PROG",v,:blist,["RETURN", blast]]] shoeFluids x== x = nil => nil symbol? x and bfBeginsDollar x => [x] atom x => nil x is ["QUOTE",:.] => nil [:shoeFluids first x,:shoeFluids rest x] shoeATOMs x == x = nil => nil symbol? x => [x] atom x => nil [:shoeATOMs first x,:shoeATOMs rest x] ++ Return true if `x' is an identifier name that designates a ++ dynamic (e.g. Lisp special) variable. isDynamicVariable x == symbol? x and bfBeginsDollar x => symbolMember?(x,$constantIdentifiers) => false CONSTANTP x => false BOUNDP x or $activeNamespace = nil => true y := FIND_-SYMBOL(symbolName x,$activeNamespace) => not CONSTANTP y true false shoeCompTran1 x == atom x => if isDynamicVariable x and not symbolMember?(x,$dollarVars) then $dollarVars := [x,:$dollarVars] x U := first x U is "QUOTE" => x x is ["CASE",y,:zs] => second(x) := shoeCompTran1 y while zs ~= nil repeat second(first zs) := shoeCompTran1 second first zs zs := rest zs x x is ["L%T",l,r] => x.op := "SETQ" third(x) := shoeCompTran1 r symbol? l => bfBeginsDollar l => if not symbolMember?(l,$dollarVars) then $dollarVars := [l,:$dollarVars] x if not symbolMember?(l,$locVars) then $locVars := [l,:$locVars] x l is ["FLUID",:.] => if not symbolMember?(second l,$fluidVars) then $fluidVars := [second l,:$fluidVars] x.rest.first := second l x U is "%Leave" => (x.op := "RETURN"; x) U in '(PROG LAMBDA) => newbindings := nil for y in second x repeat not symbolMember?(y,$locVars)=> $locVars := [y,:$locVars] newbindings := [y,:newbindings] rest(x).rest := shoeCompTran1 CDDR x $locVars := [y for y in $locVars | not symbolMember?(y,newbindings)] x -- literal vectors. x is ['vector,elts] => x.op := 'VECTOR do elts is 'NIL => x.args := nil x.args := shoeCompTran1 elts.args -- elts.op is LIST x x is ['%Namespace,n] => n is "DOT" => "*PACKAGE*" ["FIND-PACKAGE",symbolName n] x.first := shoeCompTran1 first x x.rest := shoeCompTran1 rest x x bfTagged(a,b)== $op = nil => %Signature(a,b) -- surely a toplevel decl symbol? a => b is "FLUID" => bfLET(compFluid a,nil) b is "local" => bfLET(compFluid a,nil) $typings := [["TYPE",b,a],:$typings] a ["THE",b,a] bfAssign(l,r)== bfTupleP l => bfSetelt(second l,CDDR l ,r) l is ["%Place",:l'] => ["SETF",l',r] bfLET(l,r) bfSetelt(e,l,r)== rest l = nil => defSETELT(e,first l,r) bfSetelt(bfElt(e,first l),rest l,r) bfElt(expr,sel)== y := symbol? sel and sel has SHOESELFUNCTION y => integer? y => ["ELT",expr,y] [y,expr] ["ELT",expr,sel] defSETELT(var,sel,expr)== y := symbol? sel and sel has SHOESELFUNCTION y => integer? y => ["SETF",["ELT",var,y],expr] y is "CAR" => ["RPLACA",var,expr] y is "CDR" => ["RPLACD",var,expr] ["SETF",[y,var],expr] ["SETF",["ELT",var,sel],expr] bfIfThenOnly(a,b)== b1 := b is ["PROGN",:.] => rest b [b] ["COND",[a,:b1]] bfIf(a,b,c)== b1 := b is ["PROGN",:.] => rest b [b] c is ["COND",:.] => ["COND",[a,:b1],:rest c] c1 := c is ["PROGN",:.] => rest c [c] ["COND",[a,:b1],['T,:c1]] bfExit(a,b)== ["COND",[a,["IDENTITY",b]]] bfMKPROGN l== a := [:bfFlattenSeq c for c in tails l] a = nil => nil rest a = nil => first a ["PROGN",:a] bfFlattenSeq x == x = nil => nil f := first x atom f => rest x => nil [f] f is ["PROGN",:.] => rest x => [i for i in rest f| not atom i] rest f [f] ++ The body of each branch of a COND form is an implicit PROGN. ++ For readability purpose, we want to refrain from including ++ any explicit PROGN. bfWashCONDBranchBody x == x is ["PROGN",:y] => y [x] bfAlternative(a,b) == a is ["AND",:conds,["PROGN",stmt,='T]] => [["AND",:conds], :bfWashCONDBranchBody bfMKPROGN [stmt,b]] [a,:bfWashCONDBranchBody b] bfSequence l == l = nil => nil transform := [bfAlternative(a,b) for x in l while x is ["COND",[a,["IDENTITY",b]]]] no := #transform before := bfTake(no,l) aft := bfDrop(no,l) before = nil => l is [f] => f is ["PROGN",:.] => bfSequence rest f f bfMKPROGN [first l,bfSequence rest l] aft = nil => ["COND",:transform] ["COND",:transform,bfAlternative('T,bfSequence aft)] bfWhere (context,expr)== [opassoc,defs,nondefs] := defSheepAndGoats context a:=[[first d,second d,bfSUBLIS(opassoc,third d)] for d in defs] $wheredefs:=append(a,$wheredefs) bfMKPROGN bfSUBLIS(opassoc,append!(nondefs,[expr])) --shoeReadLispString(s,n)== -- n>= # s => nil -- [exp,ind]:=shoeReadLisp(s,n) -- exp = nil => nil -- [exp,:shoeReadLispString(s,ind)] bfCompHash(op,argl,body) == auxfn:= makeSymbol strconc(symbolName op,'";") computeFunction:= ["DEFUN",auxfn,argl,:body] bfTuple [computeFunction,:bfMain(auxfn,op)] shoeCompileTimeEvaluation x == ["EVAL-WHEN", [KEYWORD::COMPILE_-TOPLEVEL], x] bfMain(auxfn,op)== g1 := bfGenSymbol() arg :=["&REST",g1] computeValue := ['APPLY,["FUNCTION",auxfn],g1] cacheName := makeSymbol strconc(symbolName op,'";AL") g2:= bfGenSymbol() getCode := ['GETHASH,g1,cacheName] secondPredPair := [['SETQ,g2,getCode],g2] putCode := ['SETF ,getCode,computeValue] thirdPredPair:= ['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, ["SETF",["GET", ["QUOTE", op],["QUOTE",'cacheInfo]],["QUOTE", cacheVector]]] bfNamespace x == ['%Namespace,x] bfNameOnly: %Thing -> %Form bfNameOnly x== x is "t" => ["T"] [x] bfNameArgs: (%Thing,%Thing) -> %List %Form bfNameArgs (x,y)== y := y is ["TUPLE",:.] => rest y [y] [x,:y] bfCreateDef: %Thing -> %Form bfCreateDef x== x is [f] => ["DEFCONSTANT",f,["LIST",["QUOTE",f]]] a := [bfGenSymbol() for i in rest x] ["DEFUN",first x,a,["CONS",["QUOTE",first x],["LIST",:a]]] bfCaseItem: (%Thing,%Thing) -> %Form bfCaseItem(x,y) == [x,y] bfCase: (%Thing,%Thing) -> %Form bfCase(x,y)== -- Introduce a temporary to hold the value of the scrutinee. -- To minimize the number of GENSYMS and assignments, we want -- to do this only when the scrutinee is not reduced yet. g := atom x => x bfGenSymbol() body := ["CASE",["CAR", g], :bfCaseItems(g,y)] sameObject?(g,x) => body ["LET",[[g,x]],body] bfCaseItems: (%Thing,%List %Form) -> %List %Form bfCaseItems(g,x) == [bfCI(g,i,j) for [i,j] in x] bfCI: (%Thing,%Thing,%Thing) -> %Form bfCI(g,x,y)== a := rest x a = nil => [first x,y] b := [[i,bfCARCDR(j,g)] for i in a for j in 1.. | i isnt "DOT"] b = nil => [first x,y] [first x,["LET",b,y]] bfCARCDR: (%Short,%Thing) -> %Form bfCARCDR(n,g) == [makeSymbol strconc('"CA",bfDs n,'"R"),g] bfDs: %Short -> %String bfDs n == n = 0 => '"" strconc('"D",bfDs(n-1)) bfHandlers(n,e,hs) == main(n,e,hs,nil) where main(n,e,hs,xs) == hs = nil => ["COND", :reverse! [[true,["THROW",KEYWORD::OPEN_-AXIOM_-CATCH_-POINT,n]],:xs]] hs is [['%Catch,['%Signature,v,t],s],:hs'] => t := symbol? t => ["QUOTE",[t]] -- instantiate niladic type ctor ["QUOTE",t] main(n,e,hs',[[bfQ(["CAR",e],t),["LET",[[v,["CDR",e]]],s]],:xs]) bpTrap() codeForCatchHandlers(g,e,cs) == ehTest := ['AND,['CONSP,g], bfQ(['CAR,g],KEYWORD::OPEN_-AXIOM_-CATCH_-POINT)] ["LET",[[g,["CATCH",KEYWORD::OPEN_-AXIOM_-CATCH_-POINT,e]]], ["COND",[ehTest,bfHandlers(g,["CDR",g],cs)],[true,g]]] ++ Generate code for try-catch expressions. bfTry: (%Thing,%List %Form) -> %Thing bfTry(e,cs) == g := gensym() cs is [:cs',f] and f is ['%Finally,s] => cs' = nil => ["UNWIND-PROTECT",e,s] ["UNWIND-PROTECT",codeForCatchHandlers(g,e,cs'),s] codeForCatchHandlers(g,e,cs) ++ Generate code for `throw'-expressions bfThrow e == t := nil x := nil if e is ["%Pretend",:.] then t := third e x := second e else t := "SystemException" x := e t := symbol? t => ["QUOTE",[t]] ["QOUTE",t] ["THROW",KEYWORD::OPEN_-AXIOM_-CATCH_-POINT, ["CONS",KEYWORD::OPEN_-AXIOM_-CATCH_-POINT,["CONS",t,x]]] --% Type alias definition backquote: (%Form,%List %Symbol) -> %Form backquote(form,params) == params = nil => quote form atom form => symbolMember?(form,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 Interface Translation --% -- The Native Interface Translation support the following datatypes -- void: No value, useful only as function return type. -- -- char: Character type, corresponds to C type 'char'. -- -- byte: 8-bit data type for the unit of information; corresponds -- to C type 'unsigned char' on 8-bit char machines. -- -- Note: We require 2's complement representation. -- -- int8: 8-bit signed integer data type; int8_t in ISO C. -- uint8: 8-bit unsigned integer data type; uint8_t in ISO C. -- int16: 16-bit signed integer data type; int16_t is ISO C. -- uint16: 16-bit unsigned integer data type; uint16_t in ISO C. -- int32: 32-bit signed integer data type; int32_t in ISO C. -- uint32: 32-bit unsigned integer data type; uint32_t in ISO C. -- int64: 64-bit signed integer data type; int64_t in ISO C. -- uint64: 64-bit unsigned integer data type; uint64_t in ISO C. -- -- int: Native integer data type. Ideally should be wide enough -- to represent native address space. However, only ECL -- and GCL seems to give that guarantee at the moment. -- -- float: single precision datatype for floating poing values. -- float32 Corresponds to C type 'float'. On most architecture, -- this is a 32-bit precision IEEE 756 data type. -- -- double: double precision datatype for floating point values. -- float64 Corresponds to C type 'double'. On most architecture, -- this is a 64-bit precision IEEE 756 data type. -- -- string: a data type for strings of characters. The general -- semantics is that a string is passed by value (e.g. -- copied into a separate storage) to a native -- function. In many cases, that is appropriate (e.g. -- mkdir "foo") if just wasteful. In other cases, that is -- not appropriate, as the native function may expect a -- pass-by-reference semantics, e.g. modify the argument. -- Consequently, argument types may be combined with the -- modifiers `readonly' and `writeonly'. Note that a -- function return type may not use modifiers. -- Corresponds to C's notion of NUL-terminated string, -- 'char*'. In particular, the length of a string is -- stored as separate datum part of the data being -- transmitted. -- -- buffer: A data type constructor for array of simple data -- (e.g. array of bytes, array of float, array of double). -- This is used to communicate data between native -- functions and OpenAxiom functions. The `buffer' type -- constructor must be used in conjunction with one of the -- modifiers `readonly', `writeonly', or `readwrite', and -- instantiated with one of `char', `byte', `int', `float', -- and `double'. It cannot be used as function return type. -- Note that the length of the array is not stored as -- part of the data being transmitted. -- -- pointer: A data type constructor for pointer to simple data -- This is used to communicate pointer to foreign data -- between native functions and OpenAxiom functions. -- The `buffer' type constructor must be used in -- conjunction with one of the modifiers `readonly', -- `writeonly', or `readwrite'. $NativeSimpleDataTypes == '(char byte int pointer int8 uint8 int16 uint16 int32 uint32 int64 uint64 float float32 double float64) $NativeSimpleReturnTypes == [:$NativeSimpleDataTypes,:'(void string)] ++ Returns true if `t' is a simple native data type. isSimpleNativeType t == objectMember?(t,$NativeSimpleReturnTypes) coreSymbol: %Symbol -> %Symbol coreSymbol s == makeSymbol(symbolName s, "AxiomCore") bootSymbol: %Symbol -> %Symbol bootSymbol s == makeSymbol symbolName s unknownNativeTypeError t == fatalError strconc('"unsupported native type: ", PNAME t) nativeType t == t = nil => t atom t => t' := rest ASSOC(coreSymbol t,$NativeTypeTable) => t' := %hasFeature KEYWORD::SBCL => bfColonColon("SB-ALIEN", t') %hasFeature KEYWORD::CLISP => bfColonColon("FFI",t') t' -- ??? decree we have not discovered Unicode yet. t is "string" and %hasFeature KEYWORD::SBCL => [t',KEYWORD::EXTERNAL_-FORMAT,KEYWORD::ASCII, KEYWORD::ELEMENT_-TYPE, "BASE-CHAR"] t' t in '(byte uint8) => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),8] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT8") %hasFeature KEYWORD::ECL or %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-BYTE nativeType "char" -- approximate by 'char' for GCL t is "int16" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),16] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT16") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT16_-T => KEYWORD::INT16_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-HALFWORD unknownNativeTypeError t t is "uint16" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),16] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT16") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT16_-T => KEYWORD::UINT16_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-HALFWORD unknownNativeTypeError t t is "int32" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),32] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT32") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT32_-T => KEYWORD::INT32_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-FULLWORD unknownNativeTypeError t t is "uint32" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),32] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT32") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT32_-T => KEYWORD::UINT32_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-FULLWORD unknownNativeTypeError t t is "int64" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","SIGNED"),64] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","INT64") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT64_-T => KEYWORD::INT64_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::SIGNED_-DOUBLEWORD unknownNativeTypeError t t is "uint64" => %hasFeature KEYWORD::SBCL => [bfColonColon("SB-ALIEN","UNSIGNED"),64] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","UINT64") %hasFeature KEYWORD::ECL and %hasFeature KEYWORD::UINT64_-T => KEYWORD::UINT64_-T %hasFeature KEYWORD::CLOZURE => KEYWORD::UNSIGNED_-DOUBLEWORD unknownNativeTypeError t t is "float32" => nativeType "float" t is "float64" => nativeType "double" t is "pointer" => %hasFeature KEYWORD::GCL => "fixnum" %hasFeature KEYWORD::ECL => KEYWORD::POINTER_-VOID %hasFeature KEYWORD::SBCL => ["*",bfColonColon("SB-ALIEN","VOID")] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","C-POINTER") %hasFeature KEYWORD::CLOZURE => KEYWORD::ADDRESS unknownNativeTypeError t unknownNativeTypeError t -- composite, reference type. first t is "buffer" => %hasFeature KEYWORD::GCL => "OBJECT" %hasFeature KEYWORD::ECL => KEYWORD::OBJECT %hasFeature KEYWORD::SBCL => ["*",nativeType second t] %hasFeature KEYWORD::CLISP => bfColonColon("FFI","C-POINTER") %hasFeature KEYWORD::CLOZURE => [KEYWORD::_*, nativeType second t] unknownNativeTypeError t first t is "pointer" => -- we don't bother looking at what the pointer points to. nativeType "pointer" unknownNativeTypeError t ++ Check that `t' is a valid return type for a native function, and ++ returns its translation nativeReturnType t == objectMember?(t,$NativeSimpleReturnTypes) => nativeType t coreError strconc('"invalid return type for native function: ", PNAME t) ++ Check that `t' is a valid parameter type for a native function, ++ and returns its translation. nativeArgumentType t == objectMember?(t,$NativeSimpleDataTypes) => nativeType t -- Allow 'string' for `pass-by-value' t is "string" => nativeType t -- anything else must use a modified reference type. atom t or #t ~= 2 => coreError '"invalid argument type for a native function" [m,[c,t']] := t -- Require a modifier. not (m in '(readonly writeonly readwrite)) => coreError '"missing modifier for argument type for a native function" -- Only 'pointer' and 'buffer' can be instantiated. not (c in '(buffer pointer)) => coreError '"expected 'buffer' or 'pointer' type instance" not objectMember?(t',$NativeSimpleDataTypes) => coreError '"expected simple native data type" nativeType second t ++ True if objects of type native type `t' are sensible to GC. needsStableReference? t == t is [m,:.] and m in '(readonly writeonly readwrite) ++ coerce argument `a' to native type `t', in preparation for ++ a call to a native functions. coerceToNativeType(a,t) == -- GCL, ECL, CLISP, and CLOZURE don't do it this way. %hasFeature KEYWORD::GCL or %hasFeature KEYWORD::ECL or %hasFeature KEYWORD::CLISP or %hasFeature KEYWORD::CLOZURE => a %hasFeature KEYWORD::SBCL => not needsStableReference? t => a [.,[c,y]] := t c is "buffer" => [bfColonColon("SB-SYS","VECTOR-SAP"),a] c is "pointer" => [bfColonColon("SB-SYS","ALIEN-SAP"),a] needsStableReference? t => fatalError strconc('"don't know how to coerce argument for native type", PNAME c) fatalError '"don't know how to coerce argument for native type" ++ Generate GCL native translation for import op: s -> t for op' ++ `argtypes' is the list of GCL FFI names for types in `s'. ++ `rettype' is the GCL FFI name for `t'. genGCLnativeTranslation(op,s,t,op') == argtypes := [nativeArgumentType x for x in s] rettype := nativeReturnType t -- If a simpel DEFENTRY will do, go for it and/[isSimpleNativeType x for x in [t,:s]] => [["DEFENTRY", op, argtypes, [rettype, symbolName op']]] -- Otherwise, do it the hard way. [["CLINES",ccode], ["DEFENTRY", op, argtypes, [rettype, cop]]] where cop := strconc(symbolName op','"__stub") ccode := "strconc"/[gclTypeInC t, '" ", cop, '"(", :[cparm(x,a) for x in tails s for a in tails cargs], '") { ", (t isnt "void" => '"return "; ""), symbolName op', '"(", :[gclArgsInC(x,a) for x in tails s for a in tails cargs], '"); }" ] where cargs := [mkCArgName i for i in 0..(#s - 1)] mkCArgName i == strconc('"x",toString i) cparm(x,a) == strconc(gclTypeInC first x, '" ", first a, (rest x => '", "; '"")) gclTypeInC x == objectMember?(x,$NativeSimpleDataTypes) => symbolName x x is "void" => '"void" x is "string" => '"char*" x is [.,["pointer",.]] => "fixnum" '"object" gclArgInC(x,a) == objectMember?(x,$NativeSimpleDataTypes) => a x is "string" => a -- GCL takes responsability for the conversion [.,[c,y]] := x c is "pointer" => a y is "char" => strconc(a,'"->st.st__self") y is "byte" => strconc(a,'"->ust.ust__self") y is "int" => strconc(a,'"->fixa.fixa__self") y is "float" => strconc(a,'"->sfa.sfa__self") y is "double" => strconc(a,'"->lfa.lfa__self") coreError '"unknown argument type" gclArgsInC(x,a) == strconc(gclArgInC(first x, first a), (rest x => '", "; '"")) genECLnativeTranslation(op,s,t,op') == args := nil argtypes := nil for x in s repeat argtypes := [nativeArgumentType x,:argtypes] args := [gensym(),:args] args := reverse args rettype := nativeReturnType t [["DEFUN",op, args, [bfColonColon("FFI","C-INLINE"),args, reverse! argtypes, rettype, callTemplate(op',#args,s), KEYWORD::ONE_-LINER, true]]] where callTemplate(op,n,s) == "strconc"/[symbolName op,'"(", :[sharpArg(i,x) for i in 0..(n-1) for x in s],'")"] sharpArg(i,x) == i = 0 => strconc('"(#0)",selectDatum x) strconc('",",'"(#", toString i, '")", selectDatum x) selectDatum x == isSimpleNativeType x => '"" [.,[c,y]] := x c is "buffer" => y is "char" or y is "byte" => AxiomCore::$ECLVersionNumber < 90100 => '"->vector.self.ch" y is "char" => '"->vector.self.i8" '"->vector.self.b8" y is "int" => '"->vector.self.fix" y is "float" => '"->vector.self.sf" y is "double" => '"->vector.self.df" coreError '"unknown argument to buffer type constructor" c is "pointer" => '"" coreError '"unknown type constructor" genCLISPnativeTranslation(op,s,t,op') == -- check parameter types and return types. rettype := nativeReturnType t argtypes := [nativeArgumentType x for x in s] -- There is a curious bug in the CLisp's FFI support whereby -- foreign declarations compiled separately will have the wrong -- types when used in other modules. We work around that problem -- by defining forwarding functions to the foreign declarations -- in the same module the latter are declared. Even if and when -- that bug is fixed, we still need forwarding function because, -- CLISP's FFI takes every step to ensure that Lisp world objects -- do not mix with C world object, presumably because they are not -- from the same class. Consequently, we must allocate C-storage, -- copy data there, pass pointers to them, and possibly copy -- them back. Ugh. n := makeSymbol strconc(symbolName op, '"%clisp-hack") parms := [gensym '"parm" for x in s] -- parameters of the forward decl. -- Now, separate non-simple data from the rest. This is a triple-list -- of the form ((parameter boot-type . ffi-type) ...) unstableArgs := nil for p in parms for x in s for y in argtypes repeat needsStableReference? x => unstableArgs := [[p,x,:y],:unstableArgs] -- The actual FFI declaration for the native call. Note that -- parameter of non-simple datatype are described as being pointers. foreignDecl := [bfColonColon("FFI","DEF-CALL-OUT"),n, [KEYWORD::NAME,symbolName op'], [KEYWORD::ARGUMENTS,:[[a, x] for x in argtypes for a in parms]], [KEYWORD::RETURN_-TYPE, rettype], [KEYWORD::LANGUAGE,KEYWORD::STDC]] -- The forwarding function. We have to introduce local foreign -- variables to hold the address of converted Lisp objects. Then -- we have to copy back those that are `writeonly' or `readwrite' to -- simulate the reference semantics. Don't ever try to pass around -- gigantic buffer, you might find out that it is insanely inefficient. forwardingFun := unstableArgs = nil => ["DEFUN",op,parms, [n,:parms]] localPairs := [[a,x,y,:gensym '"loc"] for [a,x,:y] in unstableArgs] call := [n,:[actualArg(p,localPairs) for p in parms]] where actualArg(p,pairs) == a' := rest ASSOC(p,pairs) => rest rest a' p -- Fix up the call if there is any `write' parameter. call := fixups := [q | not null (q := copyBack p) for p in localPairs] where copyBack [p,x,y,:a] == x is ["readonly",:.] => nil ["SETF", p, [bfColonColon("FFI","FOREIGN-VALUE"), a]] fixups = nil => [call] [["PROG1",call, :fixups]] -- Set up local foreign variables to hold address of traveling data for [p,x,y,:a] in localPairs repeat call := [[bfColonColon("FFI","WITH-FOREIGN-OBJECT"), [a, ["FUNCALL", ["INTERN",'"getCLISPType",'"BOOTTRAN"], p], p], :call]] -- Finally, define the forwarding function. ["DEFUN",op,parms,:call] $foreignsDefsForCLisp := [foreignDecl,:$foreignsDefsForCLisp] [forwardingFun] getCLISPType a == [bfColonColon("FFI","C-ARRAY"), #a] genSBCLnativeTranslation(op,s,t,op') == -- check return type and argument types. rettype := nativeReturnType t argtypes := [nativeArgumentType x for x in s] args := [gensym() for x in s] unstableArgs := nil newArgs := nil for a in args for x in s repeat newArgs := [coerceToNativeType(a,x), :newArgs] if needsStableReference? x then unstableArgs := [a,:unstableArgs] op' := %hasFeature KEYWORD::WIN32 => strconc('"__",symbolName op') symbolName op' unstableArgs = nil => [["DEFUN",op,args, [makeSymbol('"ALIEN-FUNCALL",'"SB-ALIEN"), [makeSymbol('"EXTERN-ALIEN",'"SB-ALIEN"), op', ["FUNCTION",rettype,:argtypes]], :args]]] [["DEFUN",op,args, [bfColonColon("SB-SYS","WITH-PINNED-OBJECTS"), reverse! unstableArgs, [makeSymbol('"ALIEN-FUNCALL",'"SB-ALIEN"), [makeSymbol('"EXTERN-ALIEN",'"SB-ALIEN"), op', ["FUNCTION",rettype,:argtypes]], :reverse! newArgs]]]] ++ Generate Clozure CL's equivalent of import declaration genCLOZUREnativeTranslation(op,s,t,op') == -- check parameter types and return types. rettype := nativeReturnType t argtypes := [nativeArgumentType x for x in s] -- Build parameter list for the forwarding function parms := [gensym '"parm" for x in s] -- Separate string arguments and array arguments from scalars. -- These array arguments need to be pinned down, and the string -- arguments need to stored in a stack-allocaed NTBS. strPairs := nil aryPairs := nil for p in parms for x in s repeat x is "string" => strPairs := [[p,:gensym '"loc"], :strPairs] x is [.,["buffer",.]] => aryPairs := [[p,:gensym '"loc"], :aryPairs] -- Build the actual foreign function call. -- Note that Clozure CL does not mangle foreign function call for -- us, so we're left with more platform dependencies than needed. if %hasFeature KEYWORD::DARWIN then op' := strconc('"__",op') call := [bfColonColon("CCL","EXTERNAL-CALL"), STRING op', :args, rettype] where args() == [:[x, parm] for x in argtypes for p in parms] parm() == p' := ASSOC(p, strPairs) => rest p' p' := ASSOC(p, aryPairs) => rest p' p -- If the foreign call returns a C-string, turn it into a Lisp string. -- Note that if the C-string was malloc-ed, this will leak storage. if t is "string" then call := [bfColonColon("CCL","GET-CSTRING"), call] -- If we have array arguments from Boot, bind pointers to initial data. for arg in aryPairs repeat call := [bfColonColon("CCL", "WITH-POINTER-TO-IVECTOR"), [rest arg, first arg], call] -- Finally, if we have string arguments from Boot, copy them to -- stack-allocated NTBS. if strPairs ~= nil then call := [bfColonColon("CCL", "WITH-CSTRS"), [[rest arg, first arg] for arg in strPairs], call] -- Finally, return the definition form [["DEFUN", op, parms, call]] ++ Generate an import declaration for `op' as equivalent of the ++ foreign signature `sig'. Here, `foreign' operationally means that ++ the entity is from the C language world. genImportDeclaration(op, sig) == sig isnt ["%Signature", op', m] => coreError '"invalid signature" m isnt ["%Mapping", t, s] => coreError '"invalid function type" if s ~= nil and symbol? s then s := [s] %hasFeature KEYWORD::GCL => genGCLnativeTranslation(op,s,t,op') %hasFeature KEYWORD::SBCL => genSBCLnativeTranslation(op,s,t,op') %hasFeature KEYWORD::CLISP => genCLISPnativeTranslation(op,s,t,op') %hasFeature KEYWORD::ECL => genECLnativeTranslation(op,s,t,op') %hasFeature KEYWORD::CLOZURE => genCLOZUREnativeTranslation(op,s,t,op') fatalError '"import declaration not implemented for this Lisp"