-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. -- All rights reserved. -- Copyright (C) 2007-2012, 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 Boot grammar and parser. The parser -- is hand-written based on `parser combinators' technology. -- import includer import scanner import ast namespace BOOTTRAN module parser --% --% Snapshot of the parser state --% structure %ParserState == Record(toks: %List %Tokens, trees: %List %Ast, pren: %Short, scp: %Short, cur: %Token,tu: %LoadUnit) with parserTokens == (.toks) -- remaining token sequence parserTrees == (.trees) -- list of successful parse trees parserNesting == (.pren) -- parenthesis nesting level parserScope == (.scp) -- scope nesting level parserCurrentToken == (.cur) -- current token parserLoadUnit == (.tu) -- current translation unit makeParserState toks == mk%ParserState(toks,nil,0,0,nil,makeLoadUnit()) ++ Access the value of the current token macro parserTokenValue ps == tokenValue parserCurrentToken ps ++ Access the class of the current token macro parserTokenClass ps == tokenClass parserCurrentToken ps ++ Access the position of the current token macro parserTokenPosition ps == tokenPosition parserCurrentToken ps macro parserGensymSequenceNumber ps == currentGensymNumber parserLoadUnit ps --% bpFirstToken ps == parserCurrentToken(ps) := parserTokens ps = nil => mk%Token("ERROR","NOMORE",parserTokenPosition ps) first parserTokens ps true bpFirstTok ps == parserCurrentToken(ps) := parserTokens ps = nil => mk%Token("ERROR","NOMORE",parserTokenPosition ps) first parserTokens ps parserNesting ps > 0 and parserTokenClass ps = "KEY" => parserTokenValue ps is "SETTAB" => parserScope(ps) := parserScope ps + 1 bpNext ps parserTokenValue ps is "BACKTAB" => parserScope(ps) := parserScope ps - 1 bpNext ps parserTokenValue ps is "BACKSET" => bpNext ps true true bpNext ps == parserTokens(ps) := rest parserTokens ps bpFirstTok ps bpNextToken ps == parserTokens(ps) := rest parserTokens ps bpFirstToken ps bpRequire(ps,f) == apply(f,ps,nil) or bpTrap ps bpState ps == [parserTokens ps,parserTrees ps,parserNesting ps,parserScope ps] bpRestore(ps,x)== parserTokens(ps) := first x bpFirstToken ps parserTrees(ps) := second x parserNesting(ps) := third x parserScope(ps) := CADDDR x true bpPush(ps,x) == parserTrees(ps) := [x,:parserTrees ps] bpPushId ps == parserTrees(ps) := [bfReName parserTokenValue ps,:parserTrees ps] bpPop1 ps == a := first parserTrees ps parserTrees(ps) := rest parserTrees ps a bpPop2 ps == a := second parserTrees ps parserTrees(ps).rest := CDDR parserTrees ps a bpPop3 ps == a := third parserTrees ps parserTrees(ps).rest.rest := CDDDR parserTrees ps a bpIndentParenthesized(ps,f) == scope := parserScope ps try parserScope(ps) := 0 a := parserCurrentToken ps bpEqPeek(ps,"OPAREN") => parserNesting(ps) := parserNesting ps + 1 bpNext ps apply(f,ps,nil) and bpFirstTok ps and (bpEqPeek(ps,"CPAREN") or bpParenTrap(ps,a)) => parserNesting(ps) := parserNesting ps - 1 bpNextToken ps parserScope ps = 0 => true parserTokens(ps) := [:bpAddTokens(ps,parserScope ps),:parserTokens ps] bpFirstToken ps parserNesting ps = 0 => bpCancel ps true true bpEqPeek(ps,"CPAREN") => bpPush(ps,bfTuple []) parserNesting(ps) := parserNesting ps - 1 bpNextToken ps true bpParenTrap(ps,a) false finally parserScope(ps) := scope bpParenthesized(ps,f) == a := parserCurrentToken ps bpEqKey(ps,"OPAREN") => apply(f,ps,nil) and (bpEqKey(ps,"CPAREN") or bpParenTrap(ps,a)) => true bpEqKey(ps,"CPAREN") => bpPush(ps,bfTuple []) true bpParenTrap(ps,a) false bpBracket(ps,f) == a := parserCurrentToken ps bpEqKey(ps,"OBRACK") => apply(f,ps,nil) and (bpEqKey(ps,"CBRACK") or bpBrackTrap(ps,a)) => bpPush(ps,bfBracket bpPop1 ps) bpEqKey(ps,"CBRACK") => bpPush(ps,[]) bpBrackTrap(ps,a) false bpPileBracketed(ps,f) == bpEqKey(ps,"SETTAB") => bpEqKey(ps,"BACKTAB") => true apply(f,ps,nil) and (bpEqKey(ps,"BACKTAB") or bpPileTrap ps) => bpPush(ps,bfPile bpPop1 ps) false false bpListof(ps,f,str1,g)== apply(f,ps,nil) => bpEqKey(ps,str1) and bpRequire(ps,f) => a := parserTrees ps parserTrees(ps) := nil while bpEqKey(ps,str1) and bpRequire(ps,f) repeat nil parserTrees(ps) := [reverse! parserTrees ps,:a] bpPush(ps,FUNCALL(g, [bpPop3 ps,bpPop2 ps,:bpPop1 ps])) true false -- to do , bpListofFun(ps,f,h,g)== apply(f,ps,nil) => apply(h,ps,nil) and bpRequire(ps,f) => a := parserTrees ps parserTrees(ps) := nil while apply(h,ps,nil) and bpRequire(ps,f) repeat nil parserTrees(ps) := [reverse! parserTrees ps,:a] bpPush(ps,FUNCALL(g, [bpPop3 ps,bpPop2 ps,:bpPop1 ps])) true false bpList(ps,f,str1)== apply(f,ps,nil) => bpEqKey(ps,str1) and bpRequire(ps,f) => a := parserTrees ps parserTrees(ps) := nil while bpEqKey(ps,str1) and bpRequire(ps,f) repeat nil parserTrees(ps) := [reverse! parserTrees ps,:a] bpPush(ps,[bpPop3 ps,bpPop2 ps,:bpPop1 ps]) bpPush(ps,[bpPop1 ps]) bpPush(ps,nil) bpOneOrMore(ps,f) == apply(f,ps,nil)=> a := parserTrees ps parserTrees(ps) := nil while apply(f,ps,nil) repeat nil parserTrees(ps) := [reverse! parserTrees ps,:a] bpPush(ps,[bpPop2 ps,:bpPop1 ps]) false -- s must transform the head of the stack bpAnyNo(ps,s) == while apply(s,ps,nil) repeat nil true -- AndOr(k,p,f)= k p bpAndOr(ps,keyword,p,f)== bpEqKey(ps,keyword) and bpRequire(ps,p) and bpPush(ps,FUNCALL(f,parserLoadUnit ps,bpPop1 ps)) bpConditional(ps,f) == bpEqKey(ps,"IF") and bpRequire(ps,function bpWhere) and (bpEqKey(ps,"BACKSET") or true) => bpEqKey(ps,"SETTAB") => bpEqKey(ps,"THEN") => bpRequire(ps,f) and bpElse(ps,f) and bpEqKey(ps,"BACKTAB") bpMissing(ps,"THEN") bpEqKey(ps,"THEN") => bpRequire(ps,f) and bpElse(ps,f) bpMissing(ps,"then") false bpElse(ps,f)== a := bpState ps bpBacksetElse ps => bpRequire(ps,f) and bpPush(ps,bfIf(bpPop3 ps,bpPop2 ps,bpPop1 ps)) bpRestore(ps,a) bpPush(ps,bfIfThenOnly(bpPop2 ps,bpPop1 ps)) bpBacksetElse ps == bpEqKey(ps,"BACKSET") => bpEqKey(ps,"ELSE") bpEqKey(ps,"ELSE") bpEqPeek(ps,s) == parserTokenClass ps = "KEY" and symbolEq?(s,parserTokenValue ps) bpEqKey(ps,s) == parserTokenClass ps = "KEY" and symbolEq?(s,parserTokenValue ps) and bpNext ps bpEqKeyNextTok(ps,s) == parserTokenClass ps = "KEY" and symbolEq?(s,parserTokenValue ps) and bpNextToken ps bpPileTrap ps == bpMissing(ps,"BACKTAB") bpBrackTrap(ps,x) == bpMissingMate(ps,"]",x) bpParenTrap(ps,x) == bpMissingMate(ps,")",x) bpSpecificErrorHere(ps,key) == bpSpecificErrorAtToken(parserCurrentToken ps, key) bpSpecificErrorAtToken(tok, key) == a := tokenPosition tok SoftShoeError(a,key) bpGeneralErrorHere ps == bpSpecificErrorHere(ps,'"syntax error") bpIgnoredFromTo(pos1, pos2) == shoeConsole strconc('"ignored from line ", toString lineNo pos1) shoeConsole lineString pos1 shoeConsole strconc(shoeSpaces lineCharacter pos1,'"|") shoeConsole strconc('"ignored through line ", toString lineNo pos2) shoeConsole lineString pos2 shoeConsole strconc(shoeSpaces lineCharacter pos2,'"|") bpMissingMate(ps,close,open)== bpSpecificErrorAtToken(open, '"possibly missing mate") bpMissing(ps,close) bpMissing(ps,s) == bpSpecificErrorHere(ps,strconc(PNAME s,'" possibly missing")) throw 'TRAPPED : BootParserException bpCompMissing(ps,s) == bpEqKey(ps,s) or bpMissing(ps,s) bpTrap ps == bpGeneralErrorHere ps throw 'TRAPPED : BootParserException bpRecoverTrap ps == bpFirstToken ps pos1 := parserTokenPosition ps bpMoveTo(ps,0) pos2 := parserTokenPosition ps bpIgnoredFromTo(pos1, pos2) bpPush(ps,[['"pile syntax error"]]) bpListAndRecover(ps,f)== a := parserTrees ps b := nil parserTrees(ps) := nil done := false c := parserTokens ps while not done repeat found := try apply(f,ps,nil) catch(e: BootParserException) => e if found is "TRAPPED" then parserTokens(ps) := c bpRecoverTrap ps else if not found then parserTokens(ps) := c bpGeneralErrorHere ps bpRecoverTrap ps if bpEqKey(ps,"BACKSET") then c := parserTokens ps else if bpEqPeek(ps,"BACKTAB") or parserTokens ps = nil then done := true else parserTokens(ps) := c bpGeneralErrorHere ps bpRecoverTrap ps if bpEqPeek(ps,"BACKTAB") or parserTokens ps = nil then done:=true else bpNext ps c := parserTokens ps b := [bpPop1 ps,:b] parserTrees(ps) := a bpPush(ps,reverse! b) bpMoveTo(ps,n) == parserTokens ps = nil => true bpEqPeek(ps,"BACKTAB") => n=0 => true bpNextToken ps parserScope(ps) := parserScope ps - 1 bpMoveTo(ps,n-1) bpEqPeek(ps,"BACKSET") => n=0 => true bpNextToken ps bpMoveTo(ps,n) bpEqPeek(ps,"SETTAB") => bpNextToken ps bpMoveTo(ps,n+1) bpEqPeek(ps,"OPAREN") => bpNextToken ps parserNesting(ps) := parserNesting(ps) + 1 bpMoveTo(ps,n) bpEqPeek(ps,"CPAREN") => bpNextToken ps parserNesting(ps) := parserNesting ps - 1 bpMoveTo(ps,n) bpNextToken ps bpMoveTo(ps,n) -- A fully qualified name could be interpreted as a left reduction -- of an '::' infix operator. At the moment, we don't use -- that general interpretation. -- When this routine is called, a symbol is already pushed on the -- stack. When this routine finished execution, we have either -- reduced a '::' and a name, or nothing. In either case, a -- symbol is present on the stack. bpQualifiedName ps == bpEqPeek(ps,"COLON-COLON") => bpNext ps parserTokenClass ps = "ID" and bpPushId ps and bpNext ps and bpPush(ps,bfColonColon(bpPop2 ps, bpPop1 ps)) false ++ Name: ++ ID ++ Name :: ID bpName ps == parserTokenClass ps = "ID" => bpPushId ps bpNext ps bpAnyNo(ps,function bpQualifiedName) false ++ Constant: ++ INTEGER ++ FLOAT ++ LISP ++ LISPEXPR ++ LINE ++ QUOTE S-Expression ++ STRING bpConstTok ps == parserTokenClass ps in '(INTEGER FLOAT) => bpPush(ps,parserTokenValue ps) bpNext ps parserTokenClass ps = "LISP" => bpPush(ps,%Lisp parserTokenValue ps) and bpNext ps parserTokenClass ps = "LISPEXP" => bpPush(ps,parserTokenValue ps) and bpNext ps parserTokenClass ps = "LINE" => bpPush(ps,["+LINE",parserTokenValue ps]) and bpNext ps bpEqPeek(ps,"QUOTE") => bpNext ps bpRequire(ps,function bpSexp) and bpPush(ps,bfSymbol bpPop1 ps) bpString ps or bpFunction ps bpChar ps == parserTokenClass ps = "ID" and parserTokenValue ps is "char" => a := bpState ps bpApplication ps => s := bpPop1 ps s is ["char",.] => bpPush(ps,s) bpRestore(ps,a) false false false ++ Subroutine of bpExportItem. Parses tails of ExportItem. bpExportItemTail ps == bpEqKey(ps,"BEC") and bpRequire(ps,function bpAssign) and bpPush(ps,%Assignment(bpPop2 ps, bpPop1 ps)) or bpSimpleDefinitionTail ps ++ ExportItem: ++ Structure ++ TypeAliasDefinition ++ Signature ++ Signature := Where ++ Signature == Where bpExportItem ps == bpEqPeek(ps,"STRUCTURE") => bpStruct ps a := bpState ps bpName ps => bpEqPeek(ps,"COLON") => bpRestore(ps,a) bpRequire(ps,function bpSignature) bpExportItemTail ps or true bpRestore(ps,a) bpTypeAliasDefition ps false ++ ExportItemList: ++ Signature ++ ExportItemList Signature bpExportItemList ps == bpListAndRecover(ps,function bpExportItem) ++ ModuleInterface: ++ WHERE pile-bracketed ExporItemList bpModuleInterface ps == bpEqKey(ps,"WHERE") => bpPileBracketed(ps,function bpExportItemList) or (bpExportItem ps and bpPush(ps,[bpPop1 ps])) or bpTrap ps bpPush(ps,nil) ++ ModuleExports: ++ OPAREN IdList CPAREN bpModuleExports ps == bpParenthesized(ps,function bpIdList) => bpPush(ps,bfUntuple bpPop1 ps) bpPush(ps,nil) ++ Parse a module definitoin ++ Module: ++ MODULE Name OptionalModuleExports OptionalModuleInterface bpModule ps == bpEqKey(ps,"MODULE") => bpRequire(ps,function bpName) bpModuleExports ps bpModuleInterface ps bpPush(ps,%Module(bpPop3 ps,bpPop2 ps,bpPop1 ps)) nil ++ Parse a module import, or a import declaration for a foreign entity. ++ Import: ++ IMPORT Signature FOR Name ++ IMPORT Name ++ IMPORT NAMESPACE LongName bpImport ps == bpEqKey(ps,"IMPORT") => bpEqKey(ps,"NAMESPACE") => bpLeftAssoc(ps,'(DOT),function bpName) and bpPush(ps,%Import bfNamespace bpPop1 ps) or bpTrap ps a := bpState ps bpRequire(ps,function bpName) bpEqPeek(ps,"COLON") => bpRestore(ps,a) bpRequire(ps,function bpSignature) and (bpEqKey(ps,"FOR") or bpTrap ps) and bpRequire(ps,function bpName) and bpPush(ps,%ImportSignature(bpPop1 ps, bpPop1 ps)) bpPush(ps,%Import bpPop1 ps) false ++ ++ Namespace: ++ NAMESPACE Name bpNamespace ps == bpEqKey(ps,"NAMESPACE") and (bpName ps or bpDot ps) and bpPush(ps,bfNamespace bpPop1 ps) -- Parse a type alias defnition: -- type-alias-definition: -- identifier <=> logical-expression bpTypeAliasDefition ps == (bpTerm(ps,function bpIdList) or bpTrap ps) and bpEqKey(ps,"TDEF") and bpLogical ps and bpPush(ps,%TypeAlias(bpPop2 ps, bpPop1 ps)) ++ Parse a signature declaration ++ Signature: ++ Name COLON Mapping bpSignature ps == bpName ps and bpEqKey(ps,"COLON") and bpRequire(ps,function bpTyping) and bpPush(ps,%Signature(bpPop2 ps, bpPop1 ps)) ++ SimpleMapping: ++ Application ++ Application -> Application bpSimpleMapping ps == bpApplication ps => bpEqKey(ps,"ARROW") and bpRequire(ps,function bpApplication) and bpPush(ps,%Mapping(bpPop1 ps, [bpPop1 ps])) true false ++ ArgtypeList: ++ ( ArgtypeSequence ) ++ ArgtypeSequence: ++ SimpleMapping ++ SimpleMapping , ArgtypeSequence bpArgtypeList ps == bpTuple(ps,function bpSimpleMapping) ++ Parse a mapping expression ++ Mapping: ++ ArgtypeList -> Application bpMapping ps == bpParenthesized(ps,function bpArgtypeList) and bpEqKey(ps,"ARROW") and bpApplication ps and bpPush(ps,%Mapping(bpPop1 ps, bfUntuple bpPop1 ps)) bpCancel ps == a := bpState ps bpEqKeyNextTok(ps,"SETTAB") => bpCancel ps => bpEqKeyNextTok(ps,"BACKTAB") => true bpRestore(ps,a) false bpEqKeyNextTok(ps,"BACKTAB") => true bpRestore(ps,a) false false bpAddTokens(ps,n) == n=0 => nil n>0=> [mk%Token("KEY","SETTAB",parserTokenPosition ps),:bpAddTokens(ps,n-1)] [mk%Token("KEY","BACKTAB",parserTokenPosition ps),:bpAddTokens(ps,n+1)] bpExceptions ps == bpEqPeek(ps,"DOT") or bpEqPeek(ps,"QUOTE") or bpEqPeek(ps,"OPAREN") or bpEqPeek(ps,"CPAREN") or bpEqPeek(ps,"SETTAB") or bpEqPeek(ps,"BACKTAB") or bpEqPeek(ps,"BACKSET") bpSexpKey ps == parserTokenClass ps = "KEY" and not bpExceptions ps => a := parserTokenValue ps has SHOEINF a = nil => bpPush(ps,keywordId parserTokenValue ps) and bpNext ps bpPush(ps,a) and bpNext ps false bpAnyId ps == bpEqKey(ps,"MINUS") and (parserTokenClass ps = "INTEGER" or bpTrap ps) and bpPush(ps,-parserTokenValue ps) and bpNext ps or bpSexpKey ps or parserTokenClass ps in '(ID INTEGER STRING FLOAT) and bpPush(ps,parserTokenValue ps) and bpNext ps bpSexp ps == bpAnyId ps or bpEqKey(ps,"QUOTE") and bpRequire(ps,function bpSexp) and bpPush(ps,bfSymbol bpPop1 ps) or bpIndentParenthesized(ps,function bpSexp1) bpSexp1 ps == bpFirstTok ps and bpSexp ps and (bpEqKey(ps,"DOT") and bpSexp ps and bpPush(ps,[bpPop2 ps,:bpPop1 ps]) or bpSexp1 ps and bpPush(ps,[bpPop2 ps,:bpPop1 ps])) or bpPush(ps,nil) bpPrimary1 ps == bpParenthesizedApplication ps or bpDot ps or bpConstTok ps or bpConstruct ps or bpCase ps or bpStruct ps or bpPDefinition ps or bpBPileDefinition ps bpParenthesizedApplication ps == bpName ps and bpAnyNo(ps,function bpArgumentList) bpArgumentList ps == bpPDefinition ps and bpPush(ps,bfApplication(bpPop2 ps, bpPop1 ps)) bpPrimary ps == bpFirstTok ps and (bpPrimary1 ps or bpPrefixOperator ps ) bpDot ps == bpEqKey(ps,"DOT") and bpPush(ps,bfDot()) bpPrefixOperator ps == parserTokenClass ps = "KEY" and parserTokenValue ps has SHOEPRE and bpPushId ps and bpNext ps bpInfixOperator ps == parserTokenClass ps = "KEY" and parserTokenValue ps has SHOEINF and bpPushId ps and bpNext ps bpSelector ps == bpEqKey(ps,"DOT") and (bpPrimary ps and bpPush(ps,bfElt(bpPop2 ps,bpPop1 ps)) or bpPush(ps,bfSuffixDot bpPop1 ps)) bpApplication ps== bpPrimary ps and bpAnyNo(ps,function bpSelector) and (bpApplication ps and bpPush(ps,bfApplication(bpPop2 ps,bpPop1 ps)) or true) or bpNamespace ps ++ Typing: ++ SimpleType ++ Mapping ++ FORALL Variable DOT Typing bpTyping ps == bpEqKey(ps,"FORALL") => bpRequire(ps,function bpVariable) (bpDot ps and bpPop1 ps) or bpTrap ps bpRequire(ps,function bpTyping) bpPush(ps,%Forall(bpPop2 ps, bpPop1 ps)) bpMapping ps or bpSimpleMapping ps ++ Typed: ++ Application : Typing ++ Application @ Typing bpTyped ps == bpApplication ps and bpEqKey(ps,"COLON") => bpRequire(ps,function bpTyping) and bpPush(ps,bfTagged(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) bpEqKey(ps,"AT") => bpRequire(ps,function bpTyping) and bpPush(ps,bfRestrict(bpPop2 ps, bpPop1 ps)) true bpExpt ps == bpRightAssoc(ps,'(POWER),function bpTyped) bpInfKey(ps,s) == parserTokenClass ps = "KEY" and symbolMember?(parserTokenValue ps,s) and bpPushId ps and bpNext ps bpInfGeneric(ps,s) == bpInfKey(ps,s) and (bpEqKey(ps,"BACKSET") or true) bpRightAssoc(ps,o,p)== a := bpState ps apply(p,ps,nil) => while bpInfGeneric(ps,o) and (bpRightAssoc(ps,o,p) or bpTrap ps) repeat bpPush(ps,bfInfApplication(bpPop2 ps,bpPop2 ps,bpPop1 ps)) true bpRestore(ps,a) false bpLeftAssoc(ps,operations,parser)== apply(parser,ps,nil) => while bpInfGeneric(ps,operations) and bpRequire(ps,parser) repeat bpPush(ps,bfInfApplication(bpPop2 ps,bpPop2 ps,bpPop1 ps)) true false bpString ps == parserTokenClass ps = "STRING" and bpPush(ps,quote makeSymbol parserTokenValue ps) and bpNext ps bpFunction ps == bpEqKey(ps,"FUNCTION") and bpRequire(ps,function bpPrimary1) and bpPush(ps,bfFunction bpPop1 ps) bpThetaName ps == parserTokenClass ps = "ID" and parserTokenValue ps has SHOETHETA => bpPushId ps bpNext ps false bpReduceOperator ps == bpInfixOperator ps or bpString ps or bpThetaName ps bpReduce ps == a := bpState ps bpReduceOperator ps and bpEqKey(ps,"SLASH") => bpEqPeek(ps,"OBRACK") => bpRequire(ps,function bpDConstruct) and bpPush(ps,bfReduceCollect(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) bpRequire(ps,function bpApplication) and bpPush(ps,bfReduce(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) bpRestore(ps,a) false bpTimes ps == bpReduce ps or bpLeftAssoc(ps,'(TIMES SLASH),function bpExpt) bpEuclid ps == bpLeftAssoc(ps,'(QUO REM),function bpTimes) bpMinus ps == bpInfGeneric(ps,'(MINUS)) and bpRequire(ps,function bpEuclid) and bpPush(ps,bfApplication(bpPop2 ps,bpPop1 ps)) or bpEuclid ps bpArith ps == bpLeftAssoc(ps,'(PLUS MINUS),function bpMinus) bpIs ps == bpArith ps and bpInfKey(ps,'(IS ISNT)) and bpRequire(ps,function bpPattern) => bpPush(ps,bfISApplication(parserLoadUnit ps,bpPop2 ps,bpPop2 ps,bpPop1 ps)) bpEqKey(ps,"HAS") and bpRequire(ps,function bpApplication) => bpPush(ps,bfHas(bpPop2 ps, bpPop1 ps)) true bpBracketConstruct(ps,f)== bpBracket(ps,f) and bpPush(ps,bfConstruct bpPop1 ps) bpCompare ps == bpIs ps and (bpInfKey(ps,'(SHOEEQ SHOENE LT LE GT GE IN)) and bpRequire(ps,function bpIs) and bpPush(ps,bfInfApplication(bpPop2 ps,bpPop2 ps,bpPop1 ps)) or true) or bpLeave ps or bpThrow ps bpAnd ps == bpLeftAssoc(ps,'(AND),function bpCompare) bpThrow ps == bpEqKey(ps,"THROW") and bpApplication ps => -- Allow user-supplied matching type tag if bpEqKey(ps,"COLON") then bpRequire(ps,function bpApplication) bpPush(ps,%Pretend(bpPop2 ps,bpPop1 ps)) bpPush(ps,bfThrow bpPop1 ps) nil ++ Try: ++ try Assign CatchItems bpTry ps == bpEqKey(ps,"TRY") => bpAssign ps cs := [] while bpHandler(ps,"CATCH") repeat bpCatchItem ps cs := [bpPop1 ps,:cs] bpHandler(ps,"FINALLY") => bpFinally ps and bpPush(ps,bfTry(bpPop2 ps,reverse! [bpPop1 ps,:cs])) cs = nil => bpTrap ps -- missing handlers bpPush(ps,bfTry(bpPop1 ps,reverse! cs)) nil bpCatchItem ps == bpRequire(ps,function bpExceptionVariable) and (bpEqKey(ps,"EXIT") or bpTrap ps) and bpRequire(ps,function bpAssign) and bpPush(ps,%Catch(bpPop2 ps,bpPop1 ps)) bpExceptionVariable ps == t := parserCurrentToken ps bpEqKey(ps,"OPAREN") and bpRequire(ps,function bpSignature) and (bpEqKey(ps,"CPAREN") or bpMissing(ps,t)) or bpTrap ps bpFinally ps == bpRequire(ps,function bpAssign) and bpPush(ps,%Finally bpPop1 ps) bpHandler(ps,key) == s := bpState ps (bpEqKey(ps,"BACKSET") or bpEqKey(ps,"SEMICOLON")) and bpEqKey(ps,key) => true bpRestore(ps,s) false ++ Leave: ++ LEAVE Logical bpLeave ps == bpEqKey(ps,"LEAVE") and bpRequire(ps,function bpLogical) and bpPush(ps,bfLeave bpPop1 ps) ++ Do: ++ IN Namespace Do ++ DO Assign bpDo ps == bpEqKey(ps,"IN") => bpRequire(ps,function bpNamespace) bpRequire(ps,function bpDo) bpPush(ps,bfAtScope(bpPop2 ps,bpPop1 ps)) bpEqKey(ps,"DO") and bpRequire(ps,function bpAssign) and bpPush(ps,bfDo bpPop1 ps) ++ Return: ++ RETURN Assign ++ Leave ++ Throw ++ And bpReturn ps== (bpEqKey(ps,"RETURN") and bpRequire(ps,function bpAssign) and bpPush(ps,bfReturnNoName bpPop1 ps)) or bpLeave ps or bpThrow ps or bpAnd ps or bpDo ps bpLogical ps == bpLeftAssoc(ps,'(OR),function bpReturn) bpExpression ps == bpEqKey(ps,"COLON") and (bpLogical ps and bpPush(ps,bfApplication ("COLON",bpPop1 ps)) or bpTrap ps) or bpLogical ps bpStatement ps == bpConditional(ps,function bpWhere) or bpLoop ps or bpExpression ps or bpTry ps bpLoop ps == bpIterators ps and (bpCompMissing(ps,"REPEAT") and bpRequire(ps,function bpWhere) and bpPush(ps,bfLp(parserLoadUnit ps,bpPop2 ps,bpPop1 ps))) or bpEqKey(ps,"REPEAT") and bpRequire(ps,function bpLogical) and bpPush(ps,bfLoop1(parserLoadUnit ps,bpPop1 ps)) bpSuchThat ps == bpAndOr(ps,"BAR",function bpWhere,function bfSuchthat) bpWhile ps == bpAndOr(ps,"WHILE",function bpLogical,function bfWhile) bpUntil ps == bpAndOr(ps,"UNTIL",function bpLogical,function bfUntil) bpFormal ps == bpVariable ps or bpDot ps bpForIn ps == bpEqKey(ps,"FOR") and bpRequire(ps,function bpFormal) and (bpCompMissing(ps,"IN")) and (bpRequire(ps,function bpSeg) and (bpEqKey(ps,"BY") and bpRequire(ps,function bpArith) and bpPush(ps,bfForInBy(parserLoadUnit ps,bpPop3 ps,bpPop2 ps,bpPop1 ps))) or bpPush(ps,bfForin(parserLoadUnit ps,bpPop2 ps,bpPop1 ps))) bpSeg ps == bpArith ps and (bpEqKey(ps,"SEG") and (bpArith ps and bpPush(ps,bfSegment2(bpPop2 ps,bpPop1 ps)) or bpPush(ps,bfSegment1(bpPop1 ps))) or true) bpIterator ps == bpForIn ps or bpSuchThat ps or bpWhile ps or bpUntil ps bpIteratorList ps == bpOneOrMore(ps,function bpIterator) and bpPush(ps,bfIterators bpPop1 ps) bpCrossBackSet ps == bpEqKey(ps,"CROSS") and (bpEqKey(ps,"BACKSET") or true) bpIterators ps == bpListofFun(ps,function bpIteratorList, function bpCrossBackSet,function bfCross) bpAssign ps == a := bpState ps bpStatement ps => bpEqPeek(ps,"BEC") => bpRestore(ps,a) bpRequire(ps,function bpAssignment) bpEqPeek(ps,"GIVES") => bpRestore(ps,a) bpRequire(ps,function bpLambda) bpEqPeek(ps,"LARROW") => bpRestore(ps,a) bpRequire(ps,function bpKeyArg) true bpRestore(ps,a) false bpAssignment ps == bpAssignVariable ps and bpEqKey(ps,"BEC") and bpRequire(ps,function bpAssign) and bpPush(ps,bfAssign(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) ++ Parse a lambda expression ++ Lambda ::= Variable +-> Assign bpLambda ps == bpVariable ps and bpEqKey(ps,"GIVES") and bpRequire(ps,function bpAssign) and bpPush(ps,bfLambda(bpPop2 ps,bpPop1 ps)) bpKeyArg ps == bpName ps and bpEqKey(ps,"LARROW") and bpLogical ps and bpPush(ps,bfKeyArg(bpPop2 ps,bpPop1 ps)) -- should only be allowed in sequences bpExit ps == bpAssign ps and (bpEqKey(ps,"EXIT") and (bpRequire(ps,function bpWhere) and bpPush(ps,bfExit(bpPop2 ps,bpPop1 ps))) or true) bpDefinition ps == bpEqKey(ps,"MACRO") => bpName ps and bpStoreName ps and bpCompoundDefinitionTail(ps,function %Macro) or bpTrap ps a := bpState ps bpExit ps => bpEqPeek(ps,"DEF") => bpRestore(ps,a) bpDef ps bpEqPeek(ps,"TDEF") => bpRestore(ps,a) bpTypeAliasDefition ps true bpRestore(ps,a) false bpStoreName ps == $op := first parserTrees ps sideConditions(parserLoadUnit ps) := nil $typings := nil true bpDef ps == bpName ps and bpStoreName ps and bpDefTail(ps,function %Definition) or bpNamespace ps and bpSimpleDefinitionTail ps bpDDef ps == bpName ps and bpDefTail(ps,function %Definition) ++ Parse the remaining of a simple definition. bpSimpleDefinitionTail ps == bpEqKey(ps,"DEF") and bpRequire(ps,function bpWhere) and bpPush(ps,%ConstantDefinition(bpPop2 ps, bpPop1 ps)) ++ Parse the remaining of a compound definition. bpCompoundDefinitionTail(ps,f) == bpVariable ps and bpEqKey(ps,"DEF") and bpRequire(ps,function bpWhere) and bpPush(ps,apply(f,[bpPop3 ps,bpPop2 ps,bpPop1 ps])) ++ Parse the remainding of a definition. When we reach this point ++ we know we must parse a definition and we have already parsed ++ the name of the main operator in the definition. bpDefTail(ps,f) == bpSimpleDefinitionTail ps or bpCompoundDefinitionTail(ps,f) bpWhere ps == bpDefinition ps and (bpEqKey(ps,"WHERE") and bpRequire(ps,function bpDefinitionItem) and bpPush(ps,bfWhere(parserLoadUnit ps,bpPop1 ps,bpPop1 ps)) or true) bpDefinitionItem ps == a := bpState ps bpDDef ps => true bpRestore(ps,a) bpBDefinitionPileItems ps => true bpRestore(ps,a) bpPDefinitionItems ps => true bpRestore(ps,a) bpWhere ps bpDefinitionPileItems ps == bpListAndRecover(ps,function bpDefinitionItem) and bpPush(ps,%Pile bpPop1 ps) bpBDefinitionPileItems ps == bpPileBracketed(ps,function bpDefinitionPileItems) bpSemiColonDefinition ps == bpSemiListing(ps,function bpDefinitionItem,function %Pile) bpPDefinitionItems ps == bpParenthesized(ps,function bpSemiColonDefinition) bpComma ps == bpModule ps or bpImport ps or bpTuple(ps,function bpWhere) bpTuple(ps,p) == bpListofFun(ps,p,function bpCommaBackSet,function bfTuple) bpCommaBackSet ps == bpEqKey(ps,"COMMA") and (bpEqKey(ps,"BACKSET") or true) bpSemiColon ps == bpSemiListing(ps,function bpComma,function bfSequence) bpSemiListing(ps,p,f) == bpListofFun(ps,p,function bpSemiBackSet,f) bpSemiBackSet ps == bpEqKey(ps,"SEMICOLON") and (bpEqKey(ps,"BACKSET") or true) bpPDefinition ps == bpIndentParenthesized(ps,function bpSemiColon) bpPileItems ps == bpListAndRecover(ps,function bpSemiColon) and bpPush(ps,bfSequence bpPop1 ps) bpBPileDefinition ps == bpPileBracketed(ps,function bpPileItems) bpIteratorTail ps == (bpEqKey(ps,"REPEAT") or true) and bpIterators ps bpConstruct ps == bpBracket(ps,function bpConstruction) bpConstruction ps== bpComma ps and (bpIteratorTail ps and bpPush(ps,bfCollect(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) or bpPush(ps,bfTupleConstruct bpPop1 ps)) bpDConstruct ps == bpBracket(ps,function bpDConstruction) bpDConstruction ps == bpComma ps and (bpIteratorTail ps and bpPush(ps,bfDCollect(bpPop2 ps,bpPop1 ps)) or bpPush(ps,bfDTuple bpPop1 ps)) --PATTERN bpPattern ps == bpBracketConstruct(ps,function bpPatternL) or bpChar ps or bpName ps or bpConstTok ps bpEqual ps == bpEqKey(ps,"SHOEEQ") and (bpApplication ps or bpConstTok ps or bpTrap ps) and bpPush(ps,bfEqual bpPop1 ps) bpRegularPatternItem ps == bpEqual ps or bpConstTok ps or bpDot ps or bpName ps and ((bpEqKey(ps,"BEC") and bpRequire(ps,function bpPattern) and bpPush(ps,bfAssign(parserLoadUnit ps,bpPop2 ps,bpPop1 ps))) or true) or bpBracketConstruct(ps,function bpPatternL) bpRegularPatternItemL ps == bpRegularPatternItem ps and bpPush(ps,[bpPop1 ps]) bpRegularList ps == bpListof(ps,function bpRegularPatternItemL,"COMMA",function bfAppend) bpPatternColon ps == bpEqKey(ps,"COLON") and bpRequire(ps,function bpRegularPatternItem) and bpPush(ps,[bfColon bpPop1 ps]) -- only one colon bpPatternL ps == bpPatternList ps and bpPush(ps,bfTuple bpPop1 ps) bpPatternList ps == bpRegularPatternItemL ps => while (bpEqKey(ps,"COMMA") and (bpRegularPatternItemL ps or (bpPatternTail ps and bpPush(ps,[:bpPop2 ps,:bpPop1 ps]) or bpTrap ps;false) )) repeat bpPush(ps,[:bpPop2 ps,:bpPop1 ps]) true bpPatternTail ps bpPatternTail ps == bpPatternColon ps and (bpEqKey(ps,"COMMA") and bpRequire(ps,function bpRegularList) and bpPush(ps,[:bpPop2 ps,:bpPop1 ps]) or true) -- BOUND VARIABLE ++ We are parsing parameters in a function definition. We have ++ just seen a parameter name; we are attempting to see whether ++ it might be followed by a type annotation, or whether it actually ++ a form with a specific pattern structure, or whether it has ++ a default value. bpRegularBVItemTail ps == bpEqKey(ps,"COLON") and bpRequire(ps,function bpApplication) and bpPush(ps,bfTagged(parserLoadUnit ps,bpPop2 ps, bpPop1 ps)) or bpEqKey(ps,"BEC") and bpRequire(ps,function bpPattern) and bpPush(ps,bfAssign(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) or bpEqKey(ps,"IS") and bpRequire(ps,function bpPattern) and bpPush(ps,bfAssign(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) or bpEqKey(ps,"DEF") and bpRequire(ps,function bpApplication) and bpPush(ps,%DefaultValue(bpPop2 ps, bpPop1 ps)) bpRegularBVItem ps == bpBVString ps or bpConstTok ps or (bpName ps and (bpRegularBVItemTail ps or true)) or bpBracketConstruct(ps,function bpPatternL) bpBVString ps == parserTokenClass ps = "STRING" and bpPush(ps,["BVQUOTE",makeSymbol parserTokenValue ps]) and bpNext ps bpRegularBVItemL ps == bpRegularBVItem ps and bpPush(ps,[bpPop1 ps]) bpColonName ps == bpEqKey(ps,"COLON") and (bpName ps or bpBVString ps or bpTrap ps) -- at most one colon at end bpBoundVariablelist ps == bpRegularBVItemL ps => while (bpEqKey(ps,"COMMA") and (bpRegularBVItemL ps or (bpColonName ps and bpPush(ps,bfColonAppend(bpPop2 ps,bpPop1 ps)) or bpTrap ps;false) )) repeat bpPush(ps,[:bpPop2 ps,:bpPop1 ps]) true bpColonName ps and bpPush(ps,bfColonAppend(nil,bpPop1 ps)) bpVariable ps == bpParenthesized(ps,function bpBoundVariablelist) and bpPush(ps,bfTupleIf bpPop1 ps) or bpBracketConstruct(ps,function bpPatternL) or bpName ps or bpConstTok ps bpAssignVariable ps == bpBracketConstruct(ps,function bpPatternL) or bpAssignLHS ps bpAssignLHS ps == not bpName ps => false bpEqKey(ps,"COLON") => -- variable declaration bpRequire(ps,function bpApplication) bpPush(ps,bfLocal(bpPop2 ps,bpPop1 ps)) bpArgumentList ps and (bpEqPeek(ps,"DOT") or (bpEqPeek(ps,"BEC") and bpPush(ps,bfPlace bpPop1 ps)) or bpTrap ps) bpEqKey(ps,"DOT") => -- field path bpList(ps,function bpPrimary,"DOT") and bpChecknull ps and bpPush(ps,bfTuple([bpPop2 ps,:bpPop1 ps])) true bpChecknull ps == a := bpPop1 ps a = nil => bpTrap ps bpPush(ps,a) bpStruct ps == bpEqKey(ps,"STRUCTURE") and bpRequire(ps,function bpName) and (bpEqKey(ps,"DEF") or bpTrap ps) and (bpRecord ps or bpTypeList ps) and bpPush(ps,%Structure(bpPop2 ps,bpPop1 ps)) ++ Record: ++ "Record" "(" FieldList ")" bpRecord ps == s := bpState ps bpName ps and bpPop1 ps is "Record" => (bpParenthesized(ps,function bpFieldList) or bpTrap ps) and bpGlobalAccessors ps and bpPush(ps,%Record(bfUntuple bpPop2 ps,bpPop1 ps)) bpRestore(ps,s) false ++ FieldList: ++ Signature ++ Signature , FieldList bpFieldList ps == bpTuple(ps,function bpSignature) bpGlobalAccessors ps == bpEqKey(ps,"WITH") => bpPileBracketed(ps,function bpAccessorDefinitionList) or bpTrap ps bpPush(ps,nil) bpAccessorDefinitionList ps == bpListAndRecover(ps,function bpAccessorDefinition) ++ AccessorDefinition: ++ Name DEF FieldSection bpAccessorDefinition ps == bpRequire(ps,function bpName) and (bpEqKey(ps,"DEF") or bpTrap ps) and bpRequire(ps,function bpFieldSection) and bpPush(ps,%AccessorDef(bpPop2 ps,bpPop1 ps)) ++ FieldSection: ++ "(" DOT Name ")" bpFieldSection ps == bpParenthesized(ps,function bpSelectField) bpSelectField ps == bpEqKey(ps,"DOT") and bpName ps bpTypeList ps == bpPileBracketed(ps,function bpTypeItemList) or bpTypeItem ps and bpPush(ps,[bpPop1 ps]) bpTypeItem ps == bpTerm(ps,function bpIdList) bpTypeItemList ps == bpListAndRecover(ps,function bpTypeItem) bpTerm(ps,idListParser) == bpRequire(ps,function bpName) and ((bpParenthesized(ps,idListParser) and bpPush(ps,bfNameArgs(bpPop2 ps,bpPop1 ps))) or bpName ps and bpPush(ps,bfNameArgs(bpPop2 ps,bpPop1 ps))) or bpPush(ps,bfNameOnly bpPop1 ps) bpIdList ps == bpTuple(ps,function bpName) bpCase ps == bpEqKey(ps,"CASE") and bpRequire(ps,function bpWhere) and (bpEqKey(ps,"OF") or bpMissing(ps,"OF")) and bpPiledCaseItems ps bpPiledCaseItems ps == bpPileBracketed(ps,function bpCaseItemList) and bpPush(ps,bfCase(parserLoadUnit ps,bpPop2 ps,bpPop1 ps)) bpCaseItemList ps == bpListAndRecover(ps,function bpCaseItem) bpCasePatternVar ps == bpName ps or bpDot ps bpCasePatternVarList ps == bpTuple(ps,function bpCasePatternVar) bpCaseItem ps == (bpTerm(ps,function bpCasePatternVarList) or bpTrap ps) and (bpEqKey(ps,"EXIT") or bpTrap ps) and bpRequire(ps,function bpWhere) and bpPush(ps,bfCaseItem(bpPop2 ps,bpPop1 ps)) ++ Main entry point into the parser module. bpOutItem ps == $op: local := nil varno := parserGensymSequenceNumber ps try parserGensymSequenceNumber(ps) := 0 bpRequire(ps,function bpComma) catch(e: BootSpecificError) => bpSpecificErrorHere(ps,e) bpTrap ps finally parserGensymSequenceNumber(ps) := varno b := bpPop1 ps t := b is ["+LINE",:.] => [ b ] b is ["L%T",l,r] and symbol? l => $InteractiveMode => [["SETQ",l,r]] [["DEFPARAMETER",l,r]] translateToplevel(ps,b,false) bpPush(ps,t)