-- Copyright (C) 2007-2016, 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. -- This file contains a low-level code for parsing a Spad source file -- into an internal AST. Please note that this AST is the AST used by -- the Spad compiler, which is different from the AST used by the -- interpreter (a VAT). The AST, for the entire file, is a List Syntax -- Since this is low-level code, I don't expect people to get here, -- and you should directly use it. If you think, you need to get to -- here, then something is already wrong. -- There is a higher-level interface, written in SPAD, to this -- code. See the algebra file spad-parser.spad. -- -- -- gdr/2007-11-02 -- import lexing import parse namespace BOOT module spad_-parser where indentationLocation: %String -> %Maybe %Short --% $SKIPME := false DEFINITION__NAME := nil $preparseLastLine := nil $preparseReportIfTrue := false --% INITIALIZE_-PREPARSE rd == readerLineNumber(rd) := 0 $preparseLastLine := readerReadLine rd --% addClose(line,ch) == line.(maxIndex line) = char ";" => ch = char ";" => line line.(maxIndex line) := ch SUFFIX(char ";",line) SUFFIX(ch,line) escaped?(s,n) == n > 0 and s.(n-1) = char "__" infixToken? s == STRING2ID_-N(s,1) in '(_then _else) atEndOfUnit? x == not string? x ++ Return the logical indentation position in the `line', after ++ expansion of leading vertical tab characters. indentationLocation line == loc := 0 n := #line for i in 0.. repeat i >= n => return nil spaceChar? line.i => loc := loc + 1 tabChar? line.i => loc := 8 * (loc quo 8 + 1) return loc storeBlanks!(line,n) == #line >= n => nil stringChar(line,n) := char " " skipIfBlock rs == [n,:line] := z := preparseReadLine1 rs not string? line => z #line = 0 => skipIfBlock rs line.0 = char ")" => stringPrefix?('")if",line) => EVAL string2BootTree storeBlanks!(line,2) => preparseReadLine rs skipIfBlock rs stringPrefix?('")elseif",line) => EVAL string2BootTree storeBlanks!(line,7) => preparseReadLine rs skipIfBlock rs stringPrefix?('")else",line) or stringPrefix?('")endif",line) => preparseReadLine rs stringPrefix?('")fin",line) => [n,:%nothing] skipIfBlock rs skipIfBlock rs skipToEndif rs == [n,:line] := z := preparseReadLine1 rs not string? line => z stringPrefix?(line,'")endif") => preparseReadLine rs stringPrefix?(line,'")fin") => [n,:%nothing] skipToEndif rs ++ `n' is the line number of the current line ++ `oldnums' is the list of line numbers of previous lines ++ `oldlocs' is the list of previous indentation locations ++ `ncblock' is the current comment block findCommentBlock(n,oldnums,oldlocs,ncblock) == x := [nc,:block] := ncblock nc = 0 => [n - 1,:reverse block] [or/[n for n in oldnums for l in oldlocs | integer? l and l <= nc], :reverse block] $COMBLOCKLIST := [x,:$COMBLOCKLIST] preparseReadLine rs == [n,:line] := z := preparseReadLine1 rs not string? line or #line = 0 => z line.0 = char ")" => stringPrefix?('")if",line) => EVAL string2BootTree storeBlanks!(line,3) => preparseReadLine rs skipIfBlock rs stringPrefix?('")elseif",line) or stringPrefix?('")else",line) => skipToEndif rs stringPrefix?('")endif",line) => preparseReadLine rs stringPrefix?('")fin",line) => [n,:%nothing] z z preparseReadLine1 rs == if lines := readerPendingLines rs then line := first lines readerPendingLines(rs) := rest lines else line := expandLeadingTabs readerReadLine rs $preparseLastLine := line not string? line => [readerLineNumber rs] readerLineNumber(rs) := readerLineNumber rs + 1 line := trimTrailingBlank line n := readerLineNumber rs if #line > 0 and line.maxIndex(line) = char "__" then line := strconc(subString(line,0,maxIndex line),rest preparseReadLine1 rs) $preparseLastLine := line [n,:line] preparseEcho lines == if $Echo then for x in reverse lines repeat formatToStream($OutputStream,'"~&;~A~%",x) ++ The line to be worked on is the first in `lines. ++ It's indentation is the first in `locs'. ++ There is a notion of current indentation. Then: ++ ++ A. Add open paren to beginning of following line if following ++ line's indentation is greater than current, and add close paren ++ to end of last succeeding line with following line's indentation. ++ B. Add semicolon to end of line if following line's indentation is ++ the same. ++ C. If the entire line consists of the single keyword then or else, ++ leave it alone. addParensAndSemisToLine: (%List %String,%List %Maybe %Short) -> %Void addParensAndSemisToLine(lines,locs) == sc := first locs -- first line column number sc = nil or sc <= 0 => nil count := 0 -- number of semicolons added z := lines for x in tails rest lines for y in tails rest locs repeat do nc := first y nc = nil => nil nc := abs nc nc < sc => leave nil nc = sc and (y.first := -nc) and not infixToken? first x => z.first := addClose(first z,char ";") count := count + 1 z := rest z count > 0 => first(lines).(firstNonblankCharPosition first lines - 1) := char "(" z.first := addClose(first z,char ")") nil ++ Add parens and semis to lines to aid parsing. parsePiles(locs,lines) == for x in tails lines for y in tails locs repeat addParensAndSemisToLine(x,y) lines parsePrint l == $preparseReportIfTrue and l ~= nil => formatToStdout '"~&~% *** PREPARSE ***~%~%" for x in l repeat formatToStdout('"~5d. ~a~%",first x,rest x) formatToStdout '"~%" nil preparse1 rd == sloc := -1 parenlev := 0 ncomblock := nil lines := nil locs := nil nums := nil instring := false repeat [num,:l] := preparseReadLine rd atEndOfUnit? l => preparseEcho readerPendingLines rd lines = nil => return nil if ncomblock ~= nil then findCommentBlock(nil,nums,locs,ncomblock) return pairList(reverse! nums,parsePiles(reverse! locs,reverse! lines)) lines = nil and #l > 0 and l.0 = char ")" => preparseEcho readerPendingLines rd $preparseLastLine := nil SETQ(LINE,l) CATCH($SpadReaderTag,doSystemCommand SUBSEQ(LINE,1)) sz := #l sz = 0 => nil -- analyze the line just read psloc := sloc i := 0 instring := false pcount := 0 repeat strsym := charPosition(char "_"",l,i) comsym := findString('"--",l,i) or sz ncomsym := findString('"++",l,i) or sz oparsym := charPosition(char "(",l,i) cparsym := charPosition(char ")",l,i) n := MIN(strsym,comsym,ncomsym,oparsym,cparsym) do n = sz => leave nil -- empty line escaped?(l,n) => nil n = strsym => instring := not instring instring => nil n = comsym => -- comment l := SUBSEQ(l,0,n) leave nil n = ncomsym => -- description sloc := indentationLocation l if sloc = n then if ncomblock ~= nil and n ~= first ncomblock then findCommentBlock(num,nums,locs,ncomblock) ncomblock := nil ncomblock := [n,l,:IFCDR ncomblock] l := '"" else readerDeferLine(rd,strconc(makeString(n,char " "),subString(l,n))) readerLineNumber(rd) := readerLineNumber rd - 1 l := SUBSEQ(l,0,n) leave nil n = oparsym => pcount := pcount + 1 n = cparsym => pcount := pcount - 1 i := n + 1 sloc := indentationLocation l sloc = nil => sloc := psloc l := trimTrailingBlank l if lines = nil and sloc = 0 then if $byConstructors and findString('"==>",l) = nil and not symbolMember?(functor := makeSymbol subString(l,0,STRPOSL('": (=",l,0,nil)),$byConstructors) then $SKIPME := true else $constructorsSeen := [functor,:$constructorsSeen] $SKIPME := false lines ~= nil and sloc = 0 => if ncomblock ~= nil and first ncomblock ~= 0 then findCommentBlock(num,nums,locs,ncomblock) return pairList(reverse! nums,parsePiles(reverse! locs,reverse! lines)) do parenlev > 0 => locs := [nil,:locs] sloc := psloc if ncomblock ~= nil then findCommentBlock(num,nums,locs,ncomblock) ncomblock := nil locs := [sloc,:locs] preparseEcho readerPendingLines rd lines := [l,:lines] nums := [num,:nums] parenlev := parenlev + pcount preparse rd == $COMBLOCKLIST := nil $SKIPME := false if $preparseLastLine ~= nil then readerDeferLine(rd,$preparseLastLine) readerLineNumber(rd) := readerLineNumber rd - #readerPendingLines rd u := preparse1 rd $SKIPME => preparse rd parsePrint u $headerDocumentation := nil $docList := nil $maxSignatureLineNumber := 0 $constructorLineNumber := IFCAR IFCAR u u --% macro compulsorySyntax(rd,s) == s or SPAD__SYNTAX__ERROR rd repeatedSyntax(rd,l,p) == n := stackSize $reduceStack once := false while apply(p,[rd]) repeat once := true not once => nil x := nil for i in (n+1)..stackSize $reduceStack repeat x := [popStack1(),:x] x = nil => true pushReduction(l,x) --% parseToken(rd,tt) == tok := matchCurrentToken(rd,tt) => pushReduction(makeSymbol strconc(symbolName tt,'"Token"),tokenSymbol tok) advanceToken rd true false parseGlyph(rd,s) == matchCurrentToken(rd,'GLIPH,s) => advanceToken rd true false parseNBGlyph(rd,tok) == matchCurrentToken(rd,'GLIPH,tok) and $nonblank => advanceToken rd true false parseString rd == parseToken(rd,'SPADSTRING) parseInteger rd == parseToken(rd,'NUMBER) parseFloatBasePart rd == matchAdvanceGlyph(rd,".") => $nonblank and (t := matchCurrentToken(rd,'NUMBER)) => t := copyToken t advanceToken rd pushReduction('parseFloatBasePart,tokenNonblank? t) pushReduction('parseFloatBasePart,tokenSymbol t) pushReduction('parseFloatBasePart,0) pushReduction('parseFloatBasePart,0) nil parseFloatBase rd == integer? currentSymbol rd and currentChar rd = char "." and nextChar rd ~= char "." and parseInteger rd => compulsorySyntax(rd,parseFloatBasePart rd) integer? currentSymbol rd and charUpcase currentChar rd = char "E" and parseInteger rd => pushReduction('parseBase,0) pushReduction('parseBase,0) digit? currentChar rd and currentSymbol rd is "." => pushReduction('parseBase,0) pushReduction('parseBase,0) nil floatExponent x == ident? x => s := symbolName x charUpcase stringChar(s,0) = char "E" and #s > 1 and (and/[DIGITP stringChar(s,i) for i in 1..maxIndex s]) => readLispFromString(s,true,nil,start <- 1) nil nil parseFloatExponent rd == not ident? currentSymbol rd => nil symbolMember?(currentSymbol rd,'(e E)) and charMember?(currentChar rd,[char "+",char "-"]) => advanceToken rd parseInteger rd => true matchAdvanceGlyph(rd,"+") => compulsorySyntax(rd,parseInteger rd) matchAdvanceGlyph(rd,"-") => compulsorySyntax(rd,parseInteger rd) pushReduction('parseFloatExponent,-popStack1()) pushReduction('parseFloatExponent,0) g := floatExponent currentSymbol rd => advanceToken rd pushReduction('parseFloatExponent,g) nil parseFloat rd == parseFloatBase rd => $nonblank and parseFloatExponent rd or pushReduction('parseFloat,0) pushReduction('parseFloat, MAKE_-FLOAT(popStack4(),popStack2(),popStack2(),popStack1())) nil parseName rd == parseToken(rd,'IDENTIFIER) and pushReduction('parseName,popStack1()) parseKeyword rd == parseToken(rd,'KEYWORD) and pushReduction('parseKeyword,popStack1()) parseFormalParameter rd == parseToken(rd,'ARGUMENT_-DESIGNATOR) parseOperatorFunctionName rd == id := makeSymbolOf(matchCurrentToken(rd,'KEYWORD) or matchCurrentToken(rd,'GLIPH) or matchCurrentToken(rd,'SPECIAL_-CHAR)) symbolMember?(id,$OperatorFunctionNames) => pushReduction('parseOperatorFunctionName,id) advanceToken rd true false parseAnyId rd == parseName rd => true parseKeyword rd => true matchString(rd,'"$") => pushReduction('parseAnyId,currentSymbol rd) advanceToken rd true parseOperatorFunctionName rd parseQuad rd == matchAdvanceString(rd,'"$") and pushReduction('parseQuad,"$") parsePrimary1 rd == parseName rd => $nonblank and currentSymbol rd is "(" => compulsorySyntax(rd,parsePrimary1 rd) pushReduction('parsePrimary1,[popStack2(),popStack1()]) true parseQuad rd or parseString rd or parseInteger rd or parseFormalParameter rd => true matchSpecial(rd,char "'") => compulsorySyntax(rd,parseData rd) pushReduction('parsePrimary1,popStack1()) parseSequence rd or parseEnclosure rd parsePrimaryNoFloat rd == parsePrimary1 rd => parseTokenTail rd or true false parsePrimary rd == parseFloat rd or parsePrimaryNoFloat rd parsePrimaryOrQM rd == matchAdvanceString(rd,'"?") => pushReduction('parsePrimaryOrQM,"?") parsePrimary rd parseSpecialKeyWord rd == matchCurrentToken(rd,'IDENTIFIER) => tokenSymbol(currentToken rd) := unAbbreviateKeyword currentSymbol rd nil parseSexpr1 rd == parseInteger rd or parseString rd or parseAnyId rd => true matchAdvanceSpecial(rd,char "'") => compulsorySyntax(rd,parseSexpr1 rd) pushReduction('parseSexpr1,["QUOTE",popStack1()]) matchAdvanceGlyph(rd,"[") => stackUpdated?($reduceStack) := false repeatedSyntax(rd,'parseSexpr1,function PARSE_-Sexpr1) if not stackUpdated? $reduceStack then pushReduction('parseSexpr1,nil) compulsorySyntax(rd,matchAdvanceGlyph(rd,"]")) pushReduction('parseSexpr1,LIST2VEC popStack1()) matchAdvanceGlyph(rd,"(") => stackUpdated?($reduceStack) := false repeatedSyntax(rd,'parseSexpr1,function PARSE_-Sexpr1) if parseGlyph(rd,".") then compulsorySyntax(rd,parseSexpr1 rd) pushReduction('parseSexpr1,append!(popStack2(),popStack1())) if not stackUpdated? $reduceStack then pushReduction('parseSexpr1,nil) compulsorySyntax(rd,matchAdvanceGlyph(rd,")")) nil parseSexpr rd == advanceToken rd parseSexpr1 rd parseData rd == parseSexpr rd and pushReduction('parseData,["QUOTE",popStack1()]) parseCommand rd == matchAdvanceString(rd,'")") => --FIXME: remove matchAdvanceString compulsorySyntax(rd,parseSpecialKeyWord rd) compulsorySyntax(rd,parseSpecialCommand rd) pushReduction('parseStatement,nil) nil parseTokenOption rd == matchAdvanceString(rd,'")") and compulsorySyntax(rd,PARSE_-TokenList rd) dollarTran(dom,x) == x is [.,:.] => [['elt,dom,first x],:rest x] ['elt,dom,x] parseQualification rd == matchAdvanceString(rd,'"$") => compulsorySyntax(rd,parsePrimary1 rd) pushReduction('parseQualification,dollarTran(popStack1(),popStack1())) nil parseTokenTail rd == currentSymbol rd is "$" and (alphabetic? currentChar rd or currentChar rd = char "$" or currentChar rd = char "%" or currentChar rd = char "(") => tok := copyToken $priorToken parseQualification rd $priorToken := tok nil parseSelector rd == $nonblank and currentSymbol rd is "." and currentChar rd ~= char " " and matchAdvanceGlyph(rd,".") => compulsorySyntax(rd,parsePrimaryNoFloat rd) pushReduction('parseSelector,[popStack2(),popStack1()]) parseFloat rd or matchAdvanceGlyph(rd,".") and compulsorySyntax(rd,parsePrimary rd) => pushReduction('parseSelector,[popStack2(),popStack1()]) nil parseApplication rd == parsePrimary rd => repeatedSyntax(rd,'selectors,function parseSelector) parseApplication rd and pushReduction('parseApplication,[popStack2(),popStack1()]) true nil parseOperation(rd,$ParseMode,rbp) == matchCurrentToken(rd,'IDENTIFIER) => nil s := currentSymbol rd not symbol? s or property(s,$ParseMode) = nil => nil rbp >= parseLeftBindingPowerOf(s,$ParseMode) => nil parseGetSemanticForm(rd,s,$ParseMode,ELEMN(property(s,$ParseMode),5,nil)) parseLedPart(rd,rbp) == parseOperation(rd,'Led,rbp) and pushReduction('parseLedPart,popStack1()) parseNudPart(rd,rbp) == parseOperation(rd,'Nud,rbp) or parseReduction rd or parseForm rd => pushReduction('parseNudPart,popStack1()) parseExpr(rd,rbp) == parseNudPart(rd,rbp) => repeatedSyntax(rd,'parseExpr,function(rd +-> parseLedPart(rd,rbp))) pushReduction('parseExpr,popStack1()) nil parseInfix rd == pushReduction('parseInfix,currentSymbol rd) advanceToken rd parseTokenTail rd compulsorySyntax(rd,parseExpression rd) pushReduction('parseInfix,[popStack2(),popStack2(),popStack1()]) parsePrefix rd == pushReduction('parsePrefix,currentSymbol rd) advanceToken rd parseTokenTail rd compulsorySyntax(rd,parseExpression rd) pushReduction('parsePrefix,[popStack2(),popStack1()]) parseLeftBindingPowerOf(x,p) == y := property(x,p) => ELEMN(y,3,0) 0 parseRightBindingPowerOf(x,p) == y := property(x,p) => ELEMN(y,4,105) 105 parseGetSemanticForm(rd,x,p,y) == z := y = nil => nil apply(y,[rd]) z ~= nil => z p = "Nud" => parsePrefix rd p = "Led" => parseInfix rd nil parseExpression rd == parseExpr(rd,parseRightBindingPowerOf(makeSymbolOf $priorToken,$ParseMode)) and pushReduction('parseExpression,popStack1()) parseSegmentTail rd == parseGlyph(rd,"..") => seg := parseExpression rd => ["SEGMENT",popStack2(),popStack1()] ["SEGMENT",popStack1()] pushReduction('parseSegmentTail,seg) nil parseReductionOp rd == s := currentSymbol rd if string? s then s := makeSymbol s -- FIXME: abolish string-quoted operators ident? s and property(s,'Led) and matchNextToken(rd,'GLIPH,"/") => pushReduction('parseReductionOp,s) advanceToken rd advanceToken rd true false parseReduction rd == parseReductionOp rd => compulsorySyntax(rd,parseExpr(rd,1000)) pushReduction('parseReduction,["%Reduce",popStack2(),popStack1()]) nil parseCategory rd == matchAdvanceKeyword(rd,"if") => compulsorySyntax(rd,parseExpression rd) compulsorySyntax(rd,matchAdvanceKeyword(rd,"then")) compulsorySyntax(rd,parseCategory rd) stackUpdated?($reduceStack) := false matchAdvanceKeyword(rd,"else") and compulsorySyntax(rd,parseCategory rd) if not stackUpdated? $reduceStack then pushReduction('alternateCategory,nil) pushReduction('parseCategory,["if",popStack3(),popStack2(),popStack1()]) matchAdvanceGlyph(rd,"(") => compulsorySyntax(rd,parseCategory rd) stackUpdated?($reduceStack) := false repeatedSyntax(rd,'unnamedCategory,function( rd +-> matchAdvanceSpecial(rd,char ";") and compulsorySyntax(rd,parseCategory rd))) if not stackUpdated? $reduceStack then pushReduction('unnamedCategory,nil) compulsorySyntax(rd,matchAdvanceSpecial(rd,char ")")) pushReduction('parseCategory,["CATEGORY",popStack2(),:popStack1()]) matchAdvanceKeyword(rd,"assume") => compulsorySyntax(rd,parseName rd) compulsorySyntax(rd,matchAdvanceGlyph(rd,"==")) compulsorySyntax(rd,parseFormula rd) pushReduction('assumption,['ATTRIBUTE,['%Rule,popStack2(),popStack1()]]) g := lineNumber readerSourceLine rd parseApplication rd or parseOperatorFunctionName rd => matchAdvanceGlyph(rd,":") => compulsorySyntax(rd,parseExpression rd) pushReduction('parseCategory,["%Signature",popStack2(),popStack1()]) recordSignatureDocumentation(nthStack 1,g) true pushReduction('parseCategory,["ATTRIBUTE",popStack1()]) recordAttributeDocumentation(nthStack 1,g) true nil parseWith rd == matchAdvanceKeyword(rd,"with") => compulsorySyntax(rd,parseCategory rd) pushReduction('parseWith,["with",popStack1()]) nil parseInfixWith rd == parseWith rd and pushReduction('parseInfixWith,["Join",popStack2(),popStack1()]) parseElseClause rd == currentSymbol rd is "if" => parseConditional rd parseExpression rd parseQuantifier rd == matchAdvanceKeyword(rd,"forall") => pushReduction('parseQuantifier,'%Forall) matchAdvanceKeyword(rd,"exist") => pushReduction('parseQuantifier,'%Exist) nil parseQuantifiedVariable rd == parseName rd => compulsorySyntax(rd,matchAdvanceGlyph(rd,":")) compulsorySyntax(rd,parseApplication rd) pushReduction('parseQuantifiedVariable,[":",popStack2(),popStack1()]) nil parseQuantifiedVariableList rd == matchAdvanceGlyph(rd,"(") => compulsorySyntax(rd,parseQuantifiedVariable rd) repeatedSyntax(rd,'repeatedVars,function(rd +-> matchAdvanceSpecial(rd,char ",") and parseQuantifiedVariable rd)) and pushReduction('parseQuantifiedVariableList, ["%Sequence",popStack2(),:popStack1()]) compulsorySyntax(rd,matchAdvanceSpecial(rd,char ")")) nil parseFormula rd == parseQuantifier rd => compulsorySyntax(rd,parseQuantifiedVariableList rd) compulsorySyntax(rd,matchAdvanceGlyph(rd,".")) compulsorySyntax(rd,parseExpression rd) pushReduction('parseFormula,[popStack3(),popStack2(),popStack1()]) parseExpression rd ++ quantified types. At the moment, these are used only in ++ pattern-mathing cases. ++ -- gdr, 2009-06-14. parseScheme rd == parseQuantifier rd => compulsorySyntax(rd,parseQuantifiedVariableList rd) compulsorySyntax(rd,matchAdvanceGlyph(rd,".")) compulsorySyntax(rd,parseExpr(rd,200)) pushReduction('parseScheme,[popStack3(),popStack2(),popStack1()]) parseApplication rd parseConditional rd == matchAdvanceKeyword(rd,"if") => compulsorySyntax(rd,parseExpression rd) compulsorySyntax(rd,matchAdvanceKeyword(rd,"then")) compulsorySyntax(rd,parseExpression rd) stackUpdated?($reduceStack) := false if matchAdvanceKeyword(rd,"else") then parseElseClause rd if not stackUpdated? $reduceStack then pushReduction('elseBranch,nil) pushReduction('parseConditional,["if",popStack3(),popStack2(),popStack1()]) nil parseSemicolon rd == matchAdvanceSpecial(rd,char ";") => parseExpr(rd,82) or pushReduction('parseSemicolon,"/throwAway") pushReduction('parseSemicolon,[";",popStack2(),popStack1()]) nil ++ We should factorize these boilerplates parseReturn rd == matchAdvanceKeyword(rd,"return") => compulsorySyntax(rd,parseExpression rd) pushReduction('parseReturn,["return",popStack1()]) nil parseThrow rd == matchAdvanceKeyword(rd,"throw") => compulsorySyntax(rd,parseExpression rd) pushReduction('parseThrow,["%Throw",popStack1()]) nil parseExit rd == matchAdvanceKeyword(rd,"exit") => x := parseExpression rd => popStack1() "$NoValue" pushReduction('parseExit,["exit",x]) nil parseLeave rd == matchAdvanceKeyword(rd,"leave") => x := parseExpression rd => popStack1() "$NoValue" pushReduction('parseLeave,["leave",x]) nil parseJump rd == s := currentSymbol rd => advanceToken rd pushReduction('parseJump,s) nil ++ Parse a block statement, e.g. a pile of expressions. parseBlock rd == parseExpr(rd,110) parseForm rd == matchAdvanceKeyword(rd,"iterate") => pushReduction('parseForm,["iterate"]) matchAdvanceKeyword(rd,"yield") => compulsorySyntax(rd,parseApplication rd) pushReduction('parseForm,["yield",popStack1()]) parseApplication rd parseVariable rd == parseName rd => matchAdvanceGlyph(rd,":") => compulsorySyntax(rd,parseApplication rd) pushReduction('parseVariable,[":",popStack2(),popStack1()]) true parsePrimary rd parseIterator rd == matchAdvanceKeyword(rd,"for") => compulsorySyntax(rd,parseVariable rd) compulsorySyntax(rd,matchAdvanceKeyword(rd,"in")) compulsorySyntax(rd,parseExpression rd) matchAdvanceKeyword(rd,"by") and compulsorySyntax(rd,parseExpr(rd,200)) and pushReduction('parseIterator,["INBY",popStack3(),popStack2(),popStack1()]) or pushReduction('parseIterator,["IN",popStack2(),popStack1()]) matchAdvanceGlyph(rd,"|") and compulsorySyntax(rd,parseExpr(rd,111)) and pushReduction('parseIterator,["|",popStack1()]) true matchAdvanceKeyword(rd,"while") => compulsorySyntax(rd,parseExpr(rd,190)) pushReduction('parseIterator,["WHILE",popStack1()]) matchAdvanceKeyword(rd,"until") => compulsorySyntax(rd,parseExpr(rd,190)) pushReduction('parseIterator,["UNTIL",popStack1()]) nil parseIteratorTails rd == matchAdvanceKeyword(rd,"repeat") => stackUpdated?($reduceStack) := false repeatedSyntax(rd,'parseIteratorTails,function parseIterator) if not stackUpdated? $reduceStack then pushReduction('crossIterators,nil) repeatedSyntax(rd,'parseIteratorTails,function parseIterator) parseLoop rd == repeatedSyntax(rd,'iterators,function parseIterator) => compulsorySyntax(rd,matchAdvanceKeyword(rd,"repeat")) compulsorySyntax(rd,parseBlock rd) pushReduction('parseLoop,["REPEAT",:popStack2(),popStack1()]) matchAdvanceKeyword(rd,"repeat") => compulsorySyntax(rd,parseBlock rd) pushReduction('parseLoop,["REPEAT",popStack1()]) nil parseDo rd == matchAdvanceKeyword(rd,"do") => compulsorySyntax(rd, parseBlock rd) pushReduction('parseDo,["%Do",popStack1()]) nil parseOpenBracket rd == s := currentSymbol rd s is "[" or s is ["elt",.,"["] => do s is ["elt",:.] => pushReduction('parseOpenBracket,["elt",second s,"construct"]) pushReduction('parseOpenBracket,"construct") advanceToken rd true false parseOpenBrace rd == s := currentSymbol rd s is "{" or s is ["elt",.,"{"] => do s is ["elt",:.] => pushReduction('parseOpenBracket,["elt",second s,"brace"]) pushReduction('parseOpenBracket,"construct") --FIXME: should be brace advanceToken rd true false parseSequence1 rd == do parseExpression rd => pushReduction('parseSequence1,[popStack2(),popStack1()]) pushReduction('parseSequence1,[popStack1()]) parseIteratorTails rd and pushReduction('parseSequence1,["COLLECT",:popStack1(),popStack1()]) true parseSequence rd == parseOpenBracket rd => compulsorySyntax(rd,parseSequence1 rd) compulsorySyntax(rd,matchAdvanceSpecial(rd,char "]")) parseOpenBrace rd => compulsorySyntax(rd,parseSequence1 rd) compulsorySyntax(rd,matchAdvanceSpecial(rd,char "}")) pushReduction('parseSequence,["brace",popStack1()]) nil parseEnclosure rd == matchAdvanceGlyph(rd,"(") => parseExpr(rd,6) => compulsorySyntax(rd,matchAdvanceSpecial(rd,char ")")) matchAdvanceSpecial(rd,char ")") => pushReduction('parseEnclosure,["%Comma"]) SPAD__SYNTAX__ERROR rd matchAdvanceGlyph(rd,"{") => parseExpr(rd,6) => compulsorySyntax(rd,matchAdvanceSpecial(rd,char "}")) pushReduction('parseEnclosure,["brace",["construct",popStack1()]]) matchAdvanceSpecial(rd,char "}") => pushReduction('parseEnclosure,["brace"]) SPAD__SYNTAX__ERROR rd matchAdvanceGlyph(rd,"[|") => parseStatement rd => compulsorySyntax(rd,matchAdvanceGlyph(rd,"|]")) pushReduction('parseEnclosure,["[||]",popStack1()]) SPAD__SYNTAX__ERROR rd nil parseCatch rd == matchSpecial(rd,char ";") and matchKeywordNext(rd,"catch") => advanceToken rd advanceToken rd compulsorySyntax(rd,parseGlyph(rd,"(")) compulsorySyntax(rd,parseQuantifiedVariable rd) compulsorySyntax(rd,matchAdvanceSpecial(rd,char ")")) compulsorySyntax(rd,parseGlyph(rd,"=>")) compulsorySyntax(rd,parseExpression rd) pushReduction('parseCatch,[popStack2(),popStack1()]) nil parseFinally rd == matchSpecial(rd,char ";") and matchKeywordNext(rd,"finally") => advanceToken rd advanceToken rd compulsorySyntax(rd,parseExpression rd) nil parseTry rd == matchAdvanceKeyword(rd,"try") => compulsorySyntax(rd,parseExpression rd) -- exception handlers: either a finally-expression, or -- a series of catch-expressions optionally followed by -- a finally-expression. parseFinally rd => pushReduction('parseTry,["%Try",popStack2(),nil,popStack1()]) compulsorySyntax(rd,repeatedSyntax(rd,'handlers,function parseCatch)) => stackUpdated?($reduceStack) := false parseFinally rd if not stackUpdated? $reduceStack then pushReduction('finalizer,nil) pushReduction('parseTry,["%Try",popStack3(),popStack2(),popStack1()]) SPAD__SYNTAX__ERROR rd nil parseMatch rd == matchAdvanceKeyword(rd,"case") => compulsorySyntax(rd,parseExpr(rd,400)) compulsorySyntax(rd,matchAdvanceKeyword(rd,"is")) compulsorySyntax(rd,parseBlock rd) pushReduction('parseMatch,["%Match",popStack2(),popStack1()]) nil ++ domain inlining. Same syntax as import directive; except ++ deliberate restriction on naming one type at a time. ++ -- gdr, 2009-02-28. parseInline rd == matchAdvanceKeyword(rd,"inline") => compulsorySyntax(rd,parseExpr(rd,1000)) pushReduction('parseInline,["%Inline",popStack1()]) nil parseImport rd == matchAdvanceKeyword(rd,"import") => compulsorySyntax(rd,parseExpr(rd,1000)) matchAdvanceGlyph(rd,":") => compulsorySyntax(rd,parseExpression rd) compulsorySyntax(rd,matchAdvanceKeyword(rd,"from")) compulsorySyntax(rd,parseExpr(rd,1000)) pushReduction('parseImport, ["%SignatureImport",popStack3(),popStack2(),popStack1()]) stackUpdated?($reduceStack) := false repeatedSyntax(rd,'imports,function(rd +-> matchAdvanceSpecial(rd,char ",") and compulsorySyntax(rd,parseExpr(rd,1000)))) if not stackUpdated? $reduceStack then pushReduction('imports,nil) pushReduction('parseImport,["import",popStack2(),:popStack1()]) nil parseStatement rd == parseExpr(rd,0) => repeatedSyntax(rd,'statements,function(rd +-> matchAdvanceGlyph(rd,",") and compulsorySyntax(rd,parseExpr(rd,0)))) => pushReduction('parseStatement,["Series",popStack2(),:popStack1()]) true false parseNewExpr rd == matchString(rd,'")") => processSynonyms() compulsorySyntax(rd,parseCommand rd) SETQ(DEFINITION__NAME,currentSymbol rd) parseStatement rd --% isTokenDelimiter rd == symbolMember?(currentSymbol rd,[")","END__UNIT","NIL"]) parseTokenList rd == repeatedSyntax(rd,'tokenList,function(rd +-> (isTokenDelimiter rd => nil; pushReduction('parseTokenList,currentSymbol rd); advanceToken rd; true))) parseCommandTail rd == stackUpdated?($reduceStack) := false repeatedSyntax(rd,'options,function parseTokenOption) if not stackUpdated? $reduceStack then pushReduction('options,nil) atEndOfLine rd and pushReduction('parseCommandTail,[popStack2(),:popStack1()]) systemCommand popStack1() true parseOption rd == matchAdvanceString(rd,'")") => --FIXME: kill matchAdvanceString compulsorySyntax(rd,repeatedSyntax(rd,'options,function parsePrimaryOrQM)) parseTokenCommandTail rd == stackUpdated?($reduceStack) := false repeatedSyntax(rd,'options,function parseOption) if not stackUpdated? $reduceStack then pushReduction('options,nil) atEndOfLine rd and pushReduction('parseCommandTail,[popStack2(),:popStack1()]) systemCommand popStack1() true parseSpecialCommand rd == matchAdvanceString(rd,'"show") => --FIXME: kill matchAdvanceString stackUpdated?($reduceStack) := true repeatedSyntax(rd,'commands,function(rd +-> matchAdvanceString(rd,'"?") or parseExpression rd)) if not stackUpdated? $reduceStack then pushReduction('commdnds,nil) pushReduction('parseSpecialCommand,["show",popStack1()]) compulsorySyntax(rd,parseCommandTail rd) symbolMember?(currentSymbol rd,$noParseCommands) => apply(currentSymbol rd,[]) true symbolMember?(currentSymbol rd,$tokenCommands) and parseTokenList rd => compulsorySyntax(rd,parseTokenCommandTail rd) repeatedSyntax(rd,'parseSpecialCommand,function parsePrimaryOrQM) and compulsorySyntax(rd,parseCommandTail rd) --% translateSpad(ifile,x) == $Index: local := 0 _*PRETTY_-PRINT_*: local := true $InteractiveMode: local := false $MACROASSOC: local := nil $NEWSPAD: local := true $semanticErrorStack: local := [] $warningStack: local := [] $e: local := $EmptyEnvironment $genSDVar: local := 0 $previousTime: local := TEMPUS_-FUGIT() $backend: local := function(x +-> PRINT_-FULL(x,$OutputStream)) compileParseTree x --% ++ Given a pathname to a source file containing Spad code, returns ++ a list of (old) AST objects representing the toplevel expressions ++ in that file. ++ ??? system commands are still executed even if they may not be ++ ??? meaningful. Eventually this code will go away when we ++ ??? finally use the new parser everwhere. parseSpadFile sourceFile == FILE_-CLOSED : local := false -- current stream closed? try -- noise to standard output $OutputStream: local := forkStreamByName "*STANDARD-OUTPUT*" -- we need to tell the post-parsing transformers that we're compiling -- Spad because few parse forms have slightly different representations -- depending on whether we are interpreter mode or compiler mode. $InteractiveMode: local := false -- we need to restore the global input stream state after we -- finished messing with it. rd := makeReader(sourceFile,$OutputStream) INIT_-BOOT_/SPAD_-READER rd INITIALIZE_-PREPARSE rd -- gather parse trees for all toplevel expressions in sourceFile. asts := [] while not readerEoi? rd repeat $lineStack: local := preparse rd $lineStack = nil => leave nil -- explicit end of input LINE: local := CDAR $lineStack CATCH($SpadReaderTag,parseNewExpr rd) asts := [parseTransform postTransform popStack1(), :asts] -- we accumulated the parse trees in reverse order reverse! asts finally -- clean up the mess, and get out of here ioClear! rd --% ++ Gliphs are symbol clumps. The gliph property of a symbol gives ++ the tree describing the tokens which begin with that symbol. ++ The token reader uses the gliph property to determine the longest token. ++ Thus `:=' is read as one token not as `:' followed by `='. for x in [ ["|", [")"], ["]"]],_ ["*", ["*"]],_ ["(", ["|"]],_ ["+", ["-", [">"]]],_ ["-", [">"]],_ ["<", ["="], ["<"]], ["/", ["\"]],_ ["\", ["/"]],_ [">", ["="], [">"]],_ ["=", ["=", [">"]] ,[">"]],_ [".", ["."]],_ ["~", ["="]],_ ["[", ["|"]],_ [":", ["="], ["-"], [":"]]_ ] repeat property(first x,'GLIPH) := rest x ++ Generic infix operators for x in ["-", "=", "*", "rem", "mod", "quo", "div", "/", "^", "**", "exquo", "+", "-", "<", ">", "<=", ">=", "~=", "and", "or", "/\", "\/", "<<", ">>"] _ repeat property(x,'GENERIC) := true --% --% --% Led and Nud have to do with operators. An operator with a Led property --% takes an operand on its left (infix/suffix operator). --% --% An operator with a Nud takes no operand on its left (prefix/nilfix). --% Some have both (e.g. - ). This terminology is from the Pratt parser. --% The translator for Scratchpad II is a modification of the Pratt parser --% which branches to special handlers when it is most convenient and --% practical to do so (Pratt's scheme cannot handle local contexts very --% easily). --% --% Both LEDs and NUDs have right and left binding powers. This is meaningful --% for prefix and infix operators. These powers are stored as the values of --% the LED and NUD properties of an atom, if the atom has such a property. --% The format is: --% > --% where the Special-Handler is the name of a function to be evaluated when --% that keyword is encountered. --% --% The default values of Left and Right Binding-Power are NIL. NIL is a --% legitimate value signifying no precedence. If the Special-Handler is NIL, --% this is just an ordinary operator (as opposed to a surfix operator like --% if-then-else). --% PARSE_-NewKEY := nil MAKEOP(x,y,keyname) == if rest x = nil or integer? second x then x := [first x,:x] if alphabetic? stringChar(symbolName first x,0) and not symbolMember?(first x,symbolValue keyname) then symbolValue(keyname) := [first x,:symbolValue keyname] property(first x,y) := x MAKENEWOP(x,y) == MAKEOP(x,y,'PARSE_-NewKEY) for j in [ ["*",800,801], ["rem",800,801], ["mod",800,801], ["quo",800,801], ["div",800,801], ["/",800,801], ["**",900,901], ["^",900,901], ["exquo",800,801], ["+",700,701], ["-",700,701], ["->",1001,1002], ["<-",1001,1002], [":",996,997], ["::",996,997], ["@",996,997], ["pretend",995,996], ["."], ["!","!",1002,1001], [",",110,111], [";",81,82,function parseSemicolon], ["<",400,400], [">",400,400], ["<<",400,400], [">>",400,400], ["<=",400,400], [">=",400,400], ["=",400,400], ["~=",400,400], ["in",400,400], ["case",400,400], ["add",400,120], ["with",2000,400,function parseInfixWith], ["has",400,400], ["where",121,104], ["when",112,190], ["is",400,400], ["isnt",400,400], ["and",250,251], ["or",200,201], ["/\",250,251], ["\/",200,201], ["..","SEGMENT",401,699,function parseSegmentTail], ["=>",123,103], ["+->",998,121], ["==","DEF",122,121], ["==>","MDEF",122,121], ["|",108,111], [":-",125,124], [":=",125,124] ] repeat MAKENEWOP(j,'Led) for j in [ ["for",130,350,function parseLoop], ["while",130,190,function parseLoop], ["until",130,190,function parseLoop], ["repeat",130,190,function parseLoop], ["import",120,0,function parseImport], ["inline",120,0,function parseInline], ["forall",998,999,function parseScheme], ["exist",998,999,function parseScheme], ["unless"], ["add",900,120], ["with",1000,300,function parseWith], ["has",400,400], ["-",701,700], ["#",999,998], ["!",1002,1001], ["'",999,999,function parseData], ["->",1001,1002], [":",194,195], ["not",260,259], ["~",260,259], ["=",400,700], ["return",202,201,function parseReturn], ["try",202,201,function parseTry], ["throw",202,201,function parseThrow], ["leave",202,201,function parseLeave], ["exit",202,201,function parseExit], ["break",202,201,function parseJump], ["iterate",202,201,function parseJump], ["from"], ["yield"], ["if",130,0,function parseConditional], ["case",130,190,function parseMatch], ["|",0,190], ["suchthat"], ["then",0,114], ["else",0,114], ["do",122,121,function parseDo] ] repeat MAKENEWOP(j,'Nud)