-- 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. import macros namespace BOOT module postpar ++ The type of parse trees. %ParseTree <=> %Number or %Symbol or %String or %Pair(%Thing,%Thing) ++ The result of processing a parse tree. %ParseForm <=> %Number or %Symbol or %String or %Pair(%Thing,%Thing) $postStack := [] --% Yet Another Parser Transformation File --These functions are used by for BOOT and SPAD code --(see new2OldLisp, e.g.) postTransform: %ParseTree -> %ParseForm postTransform y == x:= y u:= postTran x if u is ["%Comma",:l,[":",y,t]] and (and/[ident? x for x in l]) then u:= [":",["LISTOF",:l,y],t] postTransformCheck u u displayPreCompilationErrors() == n:= #($postStack:= removeDuplicates reverse! $postStack) n=0 => nil errors:= 1 '"errors" '"error" heading:= $topOp ~= '$topOp => ['" ",$topOp,'" has"] ['" You have"] sayBrightly [:heading,'"%b",n,'"%d",'"precompilation ",errors,'":"] if 1 %ParseForm postTran x == x isnt [.,:.] => postAtom x op := first x op is 'QUOTE => x symbol? op and (f:= property(op,'postTran)) => FUNCALL(f,x) op is ["elt",a,b] => u:= postTran [b,:rest x] [postTran op,:rest u] postForm x postTranList: %List %ParseTree -> %List %ParseForm postTranList x == [postTran y for y in x] postBigFloat: %ParseTree -> %ParseTree postBigFloat x == [.,mant,:expon] := x postTran [['elt,$Float,"float"],[",",[",",mant,expon],10]] postAdd: %ParseTree -> %ParseForm postAdd x == x isnt ["add",a,:b] => systemErrorHere ["postAdd",x] b=nil => postCapsule a ["add",postTran a,postCapsule first b] checkWarning: %Thing -> %Thing checkWarning msg == postError concat('"Parsing error: ",msg) checkWarningIndentation: () -> %Thing checkWarningIndentation() == checkWarning ['"Apparent indentation error following",:bright "add"] postCapsule: %ParseTree -> %ParseForm postCapsule x == x isnt [op,:.] => checkWarningIndentation() integer? op or op = "==" => ["CAPSULE",postBlockItem x] op = ";" => ["CAPSULE",:postBlockItemList postFlatten(x,";")] op = "if" => ["CAPSULE",postBlockItem x] checkWarningIndentation() postColon: %ParseTree -> %ParseForm postColon u == u is [":",x] => [":",postTran x] u is [":",x,y] => [":",postTran x,:postType y] postAtSign: %ParseTree -> %ParseForm postAtSign t == t isnt ["@",x,y] => systemErrorHere ["postAtSign",t] ["@",postTran x,:postType y] postPretend: %ParseTree -> %ParseForm postPretend t == t isnt ["pretend",x,y] => systemErrorHere ["postPretend",t] ["pretend",postTran x,:postType y] postConstruct: %ParseTree -> %ParseForm postConstruct u == u is ["construct",b] => a:= (b is [",",:.] => ["%Comma",:postFlatten(b,",")]; b) a is ["SEGMENT",p,q] => ["construct",postTranSegment(p,q)] a is ["%Comma",:l] => or/[x is [":",y] for x in l] => postMakeCons l or/[x is ["SEGMENT",:.] for x in l] => tuple2List l ["construct",:postTranList l] ["construct",postTran a] u postError: %Thing -> %Thing postError msg == BUMPERRORCOUNT 'precompilation xmsg:= $defOp ~= nil => [$defOp,'": ",:msg] msg $postStack:= [xmsg,:$postStack] nil postMakeCons: %ParseTree -> %ParseForm postMakeCons l == null l => "nil" l is [[":",a],:l'] => l' => ["append",postTran a,postMakeCons l'] postTran a ["cons",postTran first l,postMakeCons rest l] postAtom: %Atom -> %ParseForm postAtom x == x=0 => $Zero x=1 => $One x='T => "T$" -- rename T in spad code to T$ ident? x and niladicConstructor? x => [x] x="," => "%Comma" x = "^" => "**" -- always use `**' internally for exponentiation x postBlock: %ParseTree -> %ParseForm postBlock t == t isnt ["%Block",:l,x] => systemErrorHere ["postBlock",t] ["SEQ",:postBlockItemList l,["exit",postTran x]] postBlockItemList: %List %ParseTree -> %List %ParseTree postBlockItemList l == [postBlockItem x for x in l] postBlockItem: %ParseTree -> %ParseForm postBlockItem x == x:= postTran x x is ["%Comma",:l,[":",y,t]] and (and/[ident? x for x in l]) => [":",["LISTOF",:l,y],t] x postCategory: %ParseTree -> %ParseForm postCategory u == u isnt ["CATEGORY",:l] => systemErrorHere ["postCategory",u] --RDJ: ugh_ please -- someone take away need for PROGN as soon as possible null l => u op := $insidePostCategoryIfTrue => "PROGN" "CATEGORY" [op,:[fn x for x in l]] where fn x == $insidePostCategoryIfTrue: local := true postTran x postComma: %ParseTree -> %ParseForm postComma u == post%Comma ["%Comma",:postFlatten(u,",")] postDef: %ParseTree -> %ParseForm postDef t == t isnt [defOp,lhs,rhs] => systemErrorHere ["postDef",t] lhs is ["macro",name] => postMDef ["==>",name,rhs] recordHeaderDocumentation nil if $maxSignatureLineNumber ~= 0 then $docList := [["constructor",:$headerDocumentation],:$docList] $maxSignatureLineNumber := 0 --reset this for next constructor; see recordDocumentation lhs:= postTran lhs [form,targetType]:= lhs is [":",:.] => rest lhs [lhs,nil] if form isnt [.,:.] then form := [form] newLhs:= form isnt [.,:.] => form [op,:argl]:= [(x is [":",a,.] => a; x) for x in form] [op,:postDefArgs argl] argTypeList:= form isnt [.,:.] => nil [(x is [":",.,t] => t; nil) for x in rest form] typeList:= [targetType,:argTypeList] if form isnt [.,:.] then form := [form] specialCaseForm := [nil for x in form] ["DEF",newLhs,typeList,specialCaseForm,postTran rhs] postDefArgs: %List %ParseTree -> %List %ParseForm postDefArgs argl == null argl => argl argl is [[":",a],:b] => b ~= nil => postError ['" Argument",:bright a,'"of indefinite length must be last"] a isnt [.,:.] or a is ['QUOTE,:.] => a postError ['" Argument",:bright a,'"of indefinite length must be a name"] [first argl,:postDefArgs rest argl] postMDef: %ParseTree -> %ParseForm postMDef(t) == [.,lhs,rhs] := t lhs := postTran lhs [form,targetType]:= lhs is [":",:.] => rest lhs [lhs,nil] form:= form isnt [.,:.] => [form] form newLhs:= [(x is [":",a,:.] => a; x) for x in form] typeList:= [targetType,:[(x is [":",.,t] => t; nil) for x in rest form]] ["MDEF",newLhs,typeList,[nil for x in form],postTran rhs] postElt: %ParseTree -> %ParseForm postElt u == u isnt [.,a,b] => systemErrorHere ["postElt",u] a:= postTran a b is ["%Sequence",:.] => [["elt",a,"makeRecord"],:postTranList rest b] ["elt",a,postTran b] postExit: %ParseTree -> %ParseForm postExit t == t isnt ["=>",a,b] => systemErrorHere ["postExit",t] ["IF",postTran a,["exit",postTran b],"%noBranch"] postFlatten: (%ParseTree, %Symbol) -> %ParseForm postFlatten(x,op) == x is [ =op,a,b] => [:postFlatten(a,op),:postFlatten(b,op)] [x] postForm: %ParseTree -> %ParseForm postForm u == u isnt [op,:argl] => systemErrorHere ["postForm",u] x:= op isnt [.,:.] => argl':= postTranList argl op':= true=> op GETL(op,'Led) or GETL(op,'Nud) or op = 'IN => op numOfArgs:= (argl' is [["%Comma",:l]] => #l; 1) INTERNL("*",STRINGIMAGE numOfArgs,PNAME op) [op',:argl'] u:= postTranList u if u is [["%Comma",:.],:.] then postError ['" ",:bright u, '"is illegal because tuples cannot be applied!",'"%l", '" Did you misuse infix dot?"] u x is [.,["%Comma",:y]] => [first x,:y] x postIf: %ParseTree -> %ParseForm postIf t == t isnt ["if",:l] => t ["IF",:[(null (x:= postTran x) => "%noBranch"; x) for x in l]] postJoin: %ParseTree -> %ParseForm postJoin ["Join",a,:l] == a:= postTran a l:= postTranList l if l is [b] and b is [name,:.] and name in '(ATTRIBUTE SIGNATURE) then l := [["CATEGORY",b]] al:= a is ["%Comma",:c] => c [a] ["Join",:al,:l] postMapping: %ParseTree -> %ParseForm postMapping u == u isnt ["->",source,target] => u ["Mapping",postTran target,:unComma postTran source] postRepeat: %ParseTree -> %ParseForm postRepeat t == t isnt ["REPEAT",:m,x] => systemErrorHere ["postRepeat",t] ["REPEAT",:postIteratorList m,postTran x] postCollect: %ParseTree -> %ParseForm postCollect t == t isnt [constructOp,:m,x] => systemErrorHere ["postCollect",t] x is [["elt",D,"construct"],:y] => postCollect [["elt",D,"COLLECT"],:m,["construct",:y]] itl:= postIteratorList m x:= (x is ["construct",r] => r; x) --added 84/8/31 y:= postTran x finish(constructOp,itl,y) where finish(op,itl,y) == y is [":",a] => ["REDUCE","append",0,[op,:itl,a]] y is ["%Comma",:l] => newBody:= or/[x is [":",y] for x in l] => postMakeCons l or/[x is ["SEGMENT",:.] for x in l] => tuple2List l ["construct",:postTranList l] ["REDUCE","append",0,[op,:itl,newBody]] [op,:itl,y] postIteratorList: %List %ParseTree -> %List %ParseForm postIteratorList x == x is [p,:l] => (p:= postTran p) is ["IN",y,u] => u is ["|",a,b] => [["IN",y,postInSeq a],["|",b],:postIteratorList l] [["IN",y,postInSeq u],:postIteratorList l] [p,:postIteratorList l] x postin: %ParseTree -> %ParseForm postin arg == arg isnt ["in",i,seq] => systemErrorHere ["postin",arg] ["in",postTran i, postInSeq seq] postIn: %ParseTree -> %ParseForm postIn arg == arg isnt ["IN",i,seq] => systemErrorHere ["postIn",arg] ["IN",postTran i,postInSeq seq] postInSeq: %ParseTree -> %ParseForm postInSeq seq == seq is ["SEGMENT",p,q] => postTranSegment(p,q) seq is ["%Comma",:l] => tuple2List l postTran seq postTranSegment: (%ParseTree, %ParseTree) -> %ParseForm postTranSegment(p,q) == ["SEGMENT",postTran p,(q => postTran q; nil)] tuple2List: %ParseTree -> %ParseForm tuple2List l == l is [a,:l'] => u:= tuple2List l' a is ["SEGMENT",p,q] => null u => ["construct",postTranSegment(p,q)] ["nconc",["construct",postTranSegment(p,q)],tuple2List l'] null u => ["construct",postTran a] ["cons",postTran a,tuple2List l'] nil SEGMENT: %ParseTree -> %ParseForm SEGMENT(a,b) == [i for i in a..b] postReduce: %ParseTree -> %ParseForm postReduce t == t isnt ["%Reduce",op,expr] => systemErrorHere ["postReduce",t] expr is ["COLLECT",:.] => ["REDUCE",op,0,postTran expr] postReduce ["%Reduce",op,["COLLECT",["IN",g:= gensym(),expr], ["construct", g]]] postFlattenLeft: (%ParseTree, %Symbol) -> %ParseForm postFlattenLeft(x,op) ==-- x is [ =op,a,b] => [:postFlattenLeft(a,op),b] [x] postSemiColon: %ParseTree -> %ParseForm postSemiColon u == postBlock ["%Block",:postFlattenLeft(u,";")] postSequence: %ParseTree -> %ParseForm postSequence t == t isnt ["%Sequence",:l] => systemErrorHere ["postSequence",t] ['(elt $ makeRecord),:postTranList l] postSignature: %ParseTree -> %ParseForm postSignature t == t isnt ["%Signature",op,sig] => systemErrorHere ["postSignature",t] sig is ["->",:.] => sig1:= postType sig op:= postAtom (string? op => makeSymbol op; op) ["SIGNATURE",op,:removeSuperfluousMapping killColons sig1] ["SIGNATURE",postAtom op,:postType ["->","constant",sig]] killColons: %ParseTree -> %ParseForm killColons x == x isnt [.,:.] => x x is [op,:.] and op in '(Record Union %Forall %Exist) => x x is [":",.,y] => killColons y [killColons first x,:killColons rest x] postSlash: %ParseTree -> %ParseForm postSlash t == t isnt ['_/,a,b] => systemErrorHere ["postSlash",t] string? a => postTran ["%Reduce",makeSymbol a,b] ['_/,postTran a,postTran b] removeSuperfluousMapping: %ParseTree -> %ParseForm removeSuperfluousMapping sig1 == --get rid of this asap sig1 is [x,:y] and x is ["Mapping",:.] => [rest x,:y] sig1 postType: %ParseTree -> %ParseForm postType typ == typ is ["->",source,target] => source="constant" => [[postTran target],"constant"] [["Mapping",postTran target,:unComma postTran source]] typ is ["->",target] => [["Mapping",postTran target]] [postTran typ] post%Comma: %ParseTree -> %ParseForm post%Comma u == u is ["%Comma"] => u u is ["%Comma",:l,a] => (["%Comma",:postTranList rest u]) --u is ["%Comma",:l,a] => (--a:= postTran a; ["%Comma",:postTranList rest u]) --RDJ: don't understand need for above statement that is commented out postWhere: %ParseTree -> %ParseForm postWhere t == t isnt ["where",a,b] => systemErrorHere ["postWhere",t] x:= b is ["%Block",:c] => c [b] ["where",postTran a,:postTranList x] postWith: %ParseTree -> %ParseForm postWith t == t isnt ["with",a] => systemErrorHere ["postWidth",t] $insidePostCategoryIfTrue: local := true a:= postTran a a is [op,:.] and op in '(SIGNATURE ATTRIBUTE IF) => ["CATEGORY",a] a is ["PROGN",:b] => ["CATEGORY",:b] a postTransformCheck: %ParseTree -> %ParseForm postTransformCheck x == $defOp: local:= nil postcheck x postcheck: %ParseTree -> %ParseForm postcheck x == x isnt [.,:.] => nil x is ["DEF",form,[target,:.],:.] => setDefOp form postcheck rest rest x x is ['QUOTE,:.] => nil postcheck first x postcheck rest x setDefOp: %ParseForm -> %Thing setDefOp f == if f is [":",g,:.] then f := g f := (f isnt [.,:.] => f; first f) if $topOp then $defOp:= f else $topOp:= f unComma: %ParseForm -> %ParseForm unComma x == x is ["%Comma",:y] => y [x] --% %Match postAlternatives alts == alts is ["%Block",:cases] => ["%Block",:[tranAlt c for c in cases]] tranAlt alts where tranAlt c == c is ["=>",pred,conseq] => ["=>",postTran pred,postTran conseq] postTran c postMatch: %ParseTree -> %ParseForm postMatch t == t isnt ["%Match",expr,alts] => systemErrorHere ["postMatch",t] alts := alts is [";",:.] => ["%Block",:postFlattenLeft(alts,";")] alts ["%Match",postTran expr, postAlternatives alts] --% Register special parse tree tranformers. for x in [["with", :"postWith"],_ ["/", :"postSlash"],_ ["construct", :"postConstruct"],_ ["%Block", :"postBlock"],_ ["COLLECT", :"postCollect"],_ [":BF:", :"postBigFloat"],_ ["in", :"postin"],_ ["IN", :"postIn"],_ ["REPEAT", :"postRepeat"],_ ["add", :"postAdd"],_ ["%Reduce", :"postReduce"],_ [",", :"postComma"],_ [";", :"postSemiColon"],_ ["where", :"postWhere"],_ [":", :"postColon"],_ ["@", :"postAtSign"],_ ["pretend", :"postPretend"],_ ["if", :"postIf"],_ ["Join", :"postJoin"],_ ["%Signature", :"postSignature"],_ ["CATEGORY", :"postCategory"],_ ["==", :"postDef"],_ ["==>", :"postMDef"],_ ["->", :"postMapping"],_ ["=>", :"postExit"],_ ["%Match",:"postMatch"],_ ["%Comma", :"post%Comma"]] repeat property(first x, 'postTran) := rest x