diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/ChangeLog | 10 | ||||
| -rw-r--r-- | src/boot/parser.boot | 1155 | ||||
| -rw-r--r-- | src/boot/strap/includer.clisp | 4 | ||||
| -rw-r--r-- | src/boot/strap/parser.clisp | 1131 | ||||
| -rw-r--r-- | src/boot/strap/translator.clisp | 20 | ||||
| -rw-r--r-- | src/boot/strap/utility.clisp | 20 | ||||
| -rw-r--r-- | src/boot/translator.boot | 7 | ||||
| -rw-r--r-- | src/interp/spad-parser.boot | 7 |
8 files changed, 1266 insertions, 1088 deletions
diff --git a/src/ChangeLog b/src/ChangeLog index 9d3b39d2..1f8cc64b 100644 --- a/src/ChangeLog +++ b/src/ChangeLog @@ -1,3 +1,13 @@ +2012-05-29 Gabriel Dos Reis <gdr@cs.tamu.edu> + + * boot/parser.boot (%ParserState): New. + (makeParserState): Likewise. + (%Translator): Likewise. + (makeTranslator): Likewise. + Make all parsing functions take a parser state argument. + * boot/translator.boot (shoeOutParse): Adjust. + * interp/spad-parser.boot (stringPrefix?): Remove redudant definition. + 2012-05-28 Gabriel Dos Reis <gdr@cs.tamu.edu> * interp/lexing.boot: Use makeToken directly. diff --git a/src/boot/parser.boot b/src/boot/parser.boot index a830a7d9..e8843aa7 100644 --- a/src/boot/parser.boot +++ b/src/boot/parser.boot @@ -45,6 +45,38 @@ import ast namespace BOOTTRAN module parser +--% +--% Snapshot of the parser state +--% + +structure %ParserState == + Record(toks: %List %Tokens, trees: %List %Ast, pren: %Short, scp: %Short) + with + parserTokens == (.toks) -- remaining token sequence + parserTrees == (.trees) -- list of successful parse trees + parserNesting == (.pren) -- parenthesis nesting level + parserScope == (.scp) -- scope nesting level + +makeParserState toks == + mk%ParserState(toks,nil,0,0) + +--% +--% Translator global state +--% +structure %Translator == + Record(ipath: %String, fdefs: %List %Thing, sigs: %List %Thing, + xports: %List %Identifier, csts: %List %Binding) with + inputFilePath == (.ifile) -- path to the input file + functionDefinitions == (.fdefs) -- functions defined in this TU + globalSignatures == (.sigs) -- signatures proclaimed by this TU + exportedNames == (.xports) -- names exported by this TU + constantBindings == (.csts) -- constants defined in this TU + +makeTranslator ip == + mk%Translator(ip,nil,nil,nil,nil) + +--% + bpFirstToken()== $stok:= @@ -78,8 +110,8 @@ bpNextToken() == $inputStream := rest($inputStream) bpFirstToken() -bpRequire f == - apply(f,nil) or bpTrap() +bpRequire(ps,f) == + apply(f,ps,nil) or bpTrap() bpState() == [$inputStream,$stack,$bpParenCount,$bpCount] @@ -93,9 +125,10 @@ bpRestore(x)== $bpCount:=CADDDR x true -bpPush x==$stack:=[x,:$stack] +bpPush(ps,x) == + $stack:=[x,:$stack] -bpPushId()== +bpPushId ps == $stack:= [bfReName $ttok,:$stack] bpPop1()== @@ -113,13 +146,13 @@ bpPop3()== $stack.rest.rest := CDDDR $stack a -bpIndentParenthesized f== +bpIndentParenthesized(ps,f) == $bpCount:local:=0 a:=$stok bpEqPeek "OPAREN" => $bpParenCount:=$bpParenCount+1 bpNext() - apply(f,nil) and bpFirstTok() and + apply(f,ps,nil) and bpFirstTok() and (bpEqPeek "CPAREN" or bpParenTrap(a)) => $bpParenCount:=$bpParenCount-1 bpNextToken() @@ -131,113 +164,113 @@ bpIndentParenthesized f== true true bpEqPeek "CPAREN" => - bpPush bfTuple [] + bpPush(ps,bfTuple []) $bpParenCount:=$bpParenCount-1 bpNextToken() true bpParenTrap(a) false -bpParenthesized f== +bpParenthesized(ps,f) == a := $stok bpEqKey "OPAREN" => - apply(f,nil) and (bpEqKey "CPAREN" or bpParenTrap(a)) => true + apply(f,ps,nil) and (bpEqKey "CPAREN" or bpParenTrap(a)) => true bpEqKey "CPAREN" => - bpPush bfTuple [] + bpPush(ps,bfTuple []) true bpParenTrap(a) false -bpBracket f== +bpBracket(ps,f) == a := $stok bpEqKey "OBRACK" => - apply(f,nil) and (bpEqKey "CBRACK" or bpBrackTrap(a)) => - bpPush bfBracket bpPop1() - bpEqKey "CBRACK" => bpPush [] + apply(f,ps,nil) and (bpEqKey "CBRACK" or bpBrackTrap(a)) => + bpPush(ps,bfBracket bpPop1()) + bpEqKey "CBRACK" => bpPush(ps,[]) bpBrackTrap(a) false -bpPileBracketed f== +bpPileBracketed(ps,f) == bpEqKey "SETTAB" => bpEqKey "BACKTAB" => true - apply(f,nil) and (bpEqKey "BACKTAB" or bpPileTrap()) => - bpPush bfPile bpPop1() + apply(f,ps,nil) and (bpEqKey "BACKTAB" or bpPileTrap()) => + bpPush(ps,bfPile bpPop1()) false false -bpListof(f,str1,g)== - apply(f,nil) => - bpEqKey str1 and bpRequire f => +bpListof(ps,f,str1,g)== + apply(f,ps,nil) => + bpEqKey str1 and bpRequire(ps,f) => a:=$stack $stack:=nil - while bpEqKey str1 and bpRequire f repeat 0 + while bpEqKey str1 and bpRequire(ps,f) repeat nil $stack:=[reverse! $stack,:a] - bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()]) + bpPush(ps,FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()])) true false -- to do ,<backset> -bpListofFun(f,h,g)== - apply(f,nil) => - apply(h,nil) and bpRequire f => +bpListofFun(ps,f,h,g)== + apply(f,ps,nil) => + apply(h,ps,nil) and bpRequire(ps,f) => a:=$stack $stack:=nil - while apply(h,nil) and bpRequire f repeat 0 + while apply(h,ps,nil) and bpRequire(ps,f) repeat nil $stack:=[reverse! $stack,:a] - bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()]) + bpPush(ps,FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()])) true false -bpList(f,str1)== - apply(f,nil) => - bpEqKey str1 and bpRequire f => +bpList(ps,f,str1)== + apply(f,ps,nil) => + bpEqKey str1 and bpRequire(ps,f) => a:=$stack $stack:=nil - while bpEqKey str1 and bpRequire f repeat 0 + while bpEqKey str1 and bpRequire(ps,f) repeat nil $stack:=[reverse! $stack,:a] - bpPush [bpPop3(),bpPop2(),:bpPop1()] - bpPush [bpPop1()] - bpPush nil + bpPush(ps,[bpPop3(),bpPop2(),:bpPop1()]) + bpPush(ps,[bpPop1()]) + bpPush(ps,nil) -bpOneOrMore f== - apply(f,nil)=> +bpOneOrMore(ps,f) == + apply(f,ps,nil)=> a:=$stack $stack:=nil - while apply(f,nil) repeat 0 + while apply(f,ps,nil) repeat nil $stack:=[reverse! $stack,:a] - bpPush [bpPop2(),:bpPop1()] + bpPush(ps,[bpPop2(),:bpPop1()]) false -- s must transform the head of the stack -bpAnyNo s== - while apply(s,nil) repeat 0 +bpAnyNo(ps,s) == + while apply(s,ps,nil) repeat nil true -- AndOr(k,p,f)= k p -bpAndOr(keyword,p,f)== - bpEqKey keyword and bpRequire p - and bpPush FUNCALL(f, bpPop1()) +bpAndOr(ps,keyword,p,f)== + bpEqKey keyword and bpRequire(ps,p) + and bpPush(ps,FUNCALL(f, bpPop1())) -bpConditional f== - bpEqKey "IF" and bpRequire function bpWhere and (bpEqKey "BACKSET" or true) => +bpConditional(ps,f) == + bpEqKey "IF" and bpRequire(ps,function bpWhere) and (bpEqKey "BACKSET" or true) => bpEqKey "SETTAB" => bpEqKey "THEN" => - bpRequire f and bpElse(f) and bpEqKey "BACKTAB" + bpRequire(ps,f) and bpElse(ps,f) and bpEqKey "BACKTAB" bpMissing "THEN" - bpEqKey "THEN" => bpRequire f and bpElse(f) + bpEqKey "THEN" => bpRequire(ps,f) and bpElse(ps,f) bpMissing "then" false -bpElse(f)== +bpElse(ps,f)== a:=bpState() bpBacksetElse() => - bpRequire f and - bpPush bfIf(bpPop3(),bpPop2(),bpPop1()) + bpRequire(ps,f) and + bpPush(ps,bfIf(bpPop3(),bpPop2(),bpPop1())) bpRestore a - bpPush bfIfThenOnly(bpPop2(),bpPop1()) + bpPush(ps,bfIfThenOnly(bpPop2(),bpPop1())) bpBacksetElse()== bpEqKey "BACKSET" => bpEqKey "ELSE" @@ -270,15 +303,15 @@ bpTrap()== bpGeneralErrorHere() throw 'TRAPPED : BootParserException -bpRecoverTrap()== +bpRecoverTrap ps == bpFirstToken() pos1 := tokenPosition $stok bpMoveTo 0 pos2 := tokenPosition $stok bpIgnoredFromTo(pos1, pos2) - bpPush [['"pile syntax error"]] + bpPush(ps,[['"pile syntax error"]]) -bpListAndRecover(f)== +bpListAndRecover(ps,f)== a := $stack b := nil $stack := nil @@ -286,17 +319,17 @@ bpListAndRecover(f)== c := $inputStream while not done repeat found := - try apply(f,nil) + try apply(f,ps,nil) catch(e: BootParserException) => e if found is "TRAPPED" then $inputStream:=c - bpRecoverTrap() + bpRecoverTrap ps else if not found then $inputStream:=c bpGeneralErrorHere() - bpRecoverTrap() + bpRecoverTrap ps if bpEqKey "BACKSET" then c := $inputStream @@ -306,7 +339,7 @@ bpListAndRecover(f)== else $inputStream := c bpGeneralErrorHere() - bpRecoverTrap() + bpRecoverTrap ps if bpEqPeek "BACKTAB" or $inputStream = nil then done:=true else @@ -314,7 +347,7 @@ bpListAndRecover(f)== c := $inputStream b := [bpPop1(),:b] $stack := a - bpPush reverse! b + bpPush(ps,reverse! b) bpMoveTo n== $inputStream = nil => true @@ -349,21 +382,21 @@ bpMoveTo n== -- 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() == +bpQualifiedName ps == bpEqPeek "COLON-COLON" => bpNext() - tokenClass $stok = "ID" and bpPushId() and bpNext() - and bpPush bfColonColon(bpPop2(), bpPop1()) + tokenClass $stok = "ID" and bpPushId ps and bpNext() + and bpPush(ps,bfColonColon(bpPop2(), bpPop1())) false ++ Name: ++ ID ++ Name :: ID -bpName() == +bpName ps == tokenClass $stok = "ID" => - bpPushId() + bpPushId ps bpNext() - bpAnyNo function bpQualifiedName + bpAnyNo(ps,function bpQualifiedName) false ++ Constant: @@ -374,35 +407,35 @@ bpName() == ++ LINE ++ QUOTE S-Expression ++ STRING -bpConstTok() == +bpConstTok ps == tokenClass $stok in '(INTEGER FLOAT) => - bpPush $ttok + bpPush(ps,$ttok) bpNext() - tokenClass $stok = "LISP" => bpPush %Lisp $ttok and bpNext() - tokenClass $stok = "LISPEXP" => bpPush $ttok and bpNext() - tokenClass $stok = "LINE" => bpPush ["+LINE", $ttok] and bpNext() + tokenClass $stok = "LISP" => bpPush(ps,%Lisp $ttok) and bpNext() + tokenClass $stok = "LISPEXP" => bpPush(ps,$ttok) and bpNext() + tokenClass $stok = "LINE" => bpPush(ps,["+LINE", $ttok]) and bpNext() bpEqPeek "QUOTE" => bpNext() - bpRequire function bpSexp and - bpPush bfSymbol bpPop1() - bpString() or bpFunction() + bpRequire(ps,function bpSexp) and + bpPush(ps,bfSymbol bpPop1()) + bpString ps or bpFunction ps -bpChar() == +bpChar ps == tokenClass $stok = "ID" and $ttok is "char" => a := bpState() - bpApplication() => + bpApplication ps => s := bpPop1() - s is ["char",.] => bpPush s + s is ["char",.] => bpPush(ps,s) bpRestore a false false false ++ Subroutine of bpExportItem. Parses tails of ExportItem. -bpExportItemTail() == - bpEqKey "BEC" and bpRequire function bpAssign and - bpPush %Assignment(bpPop2(), bpPop1()) - or bpSimpleDefinitionTail() +bpExportItemTail ps == + bpEqKey "BEC" and bpRequire(ps,function bpAssign) and + bpPush(ps,%Assignment(bpPop2(), bpPop1())) + or bpSimpleDefinitionTail ps ++ ExportItem: ++ Structure @@ -410,48 +443,48 @@ bpExportItemTail() == ++ Signature ++ Signature := Where ++ Signature == Where -bpExportItem() == - bpEqPeek "STRUCTURE" => bpStruct() +bpExportItem ps == + bpEqPeek "STRUCTURE" => bpStruct ps a := bpState() - bpName() => + bpName ps => bpEqPeek "COLON" => bpRestore a - bpRequire function bpSignature - bpExportItemTail() or true + bpRequire(ps,function bpSignature) + bpExportItemTail ps or true bpRestore a - bpTypeAliasDefition() + bpTypeAliasDefition ps false ++ ExportItemList: ++ Signature ++ ExportItemList Signature -bpExportItemList() == - bpListAndRecover function bpExportItem +bpExportItemList ps == + bpListAndRecover(ps,function bpExportItem) ++ ModuleInterface: ++ WHERE pile-bracketed ExporItemList -bpModuleInterface() == +bpModuleInterface ps == bpEqKey "WHERE" => - bpPileBracketed function bpExportItemList - or (bpExportItem() and bpPush [bpPop1()]) + bpPileBracketed(ps,function bpExportItemList) + or (bpExportItem ps and bpPush(ps,[bpPop1()])) or bpTrap() - bpPush nil + bpPush(ps,nil) ++ ModuleExports: ++ OPAREN IdList CPAREN -bpModuleExports() == - bpParenthesized function bpIdList => bpPush bfUntuple bpPop1() - bpPush nil +bpModuleExports ps == + bpParenthesized(ps,function bpIdList) => bpPush(ps,bfUntuple bpPop1()) + bpPush(ps,nil) ++ Parse a module definitoin ++ Module: ++ MODULE Name OptionalModuleExports OptionalModuleInterface -bpModule() == +bpModule ps == bpEqKey "MODULE" => - bpRequire function bpName - bpModuleExports() - bpModuleInterface() - bpPush %Module(bpPop3(),bpPop2(),bpPop1()) + bpRequire(ps,function bpName) + bpModuleExports ps + bpModuleInterface ps + bpPush(ps,%Module(bpPop3(),bpPop2(),bpPop1())) nil ++ Parse a module import, or a import declaration for a foreign entity. @@ -459,52 +492,52 @@ bpModule() == ++ IMPORT Signature FOR Name ++ IMPORT Name ++ IMPORT NAMESPACE LongName -bpImport() == +bpImport ps == bpEqKey "IMPORT" => bpEqKey "NAMESPACE" => - bpLeftAssoc('(DOT),function bpName) and - bpPush %Import bfNamespace bpPop1() + bpLeftAssoc(ps,'(DOT),function bpName) and + bpPush(ps,%Import bfNamespace bpPop1()) or bpTrap() a := bpState() - bpRequire function bpName + bpRequire(ps,function bpName) bpEqPeek "COLON" => bpRestore a - bpRequire function bpSignature and + bpRequire(ps,function bpSignature) and (bpEqKey "FOR" or bpTrap()) and - bpRequire function bpName and - bpPush %ImportSignature(bpPop1(), bpPop1()) - bpPush %Import bpPop1() + bpRequire(ps,function bpName) and + bpPush(ps,%ImportSignature(bpPop1(), bpPop1())) + bpPush(ps,%Import bpPop1()) false ++ ++ Namespace: ++ NAMESPACE Name -bpNamespace() == - bpEqKey "NAMESPACE" and (bpName() or bpDot()) and - bpPush bfNamespace bpPop1() +bpNamespace ps == + bpEqKey "NAMESPACE" and (bpName ps or bpDot ps) and + bpPush(ps,bfNamespace bpPop1()) -- Parse a type alias defnition: -- type-alias-definition: -- identifier <=> logical-expression -bpTypeAliasDefition() == - (bpTerm function bpIdList or bpTrap()) and - bpEqKey "TDEF" and bpLogical() and - bpPush %TypeAlias(bpPop2(), bpPop1()) +bpTypeAliasDefition ps == + (bpTerm(ps,function bpIdList) or bpTrap()) and + bpEqKey "TDEF" and bpLogical ps and + bpPush(ps,%TypeAlias(bpPop2(), bpPop1())) ++ Parse a signature declaration ++ Signature: ++ Name COLON Mapping -bpSignature() == - bpName() and bpEqKey "COLON" and bpRequire function bpTyping - and bpPush %Signature(bpPop2(), bpPop1()) +bpSignature ps == + bpName ps and bpEqKey "COLON" and bpRequire(ps,function bpTyping) + and bpPush(ps,%Signature(bpPop2(), bpPop1())) ++ SimpleMapping: ++ Application ++ Application -> Application -bpSimpleMapping() == - bpApplication() => - bpEqKey "ARROW" and bpRequire function bpApplication and - bpPush %Mapping(bpPop1(), [bpPop1()]) +bpSimpleMapping ps == + bpApplication ps => + bpEqKey "ARROW" and bpRequire(ps,function bpApplication) and + bpPush(ps,%Mapping(bpPop1(), [bpPop1()])) true false @@ -513,16 +546,16 @@ bpSimpleMapping() == ++ ArgtypeSequence: ++ SimpleMapping ++ SimpleMapping , ArgtypeSequence -bpArgtypeList() == - bpTuple function bpSimpleMapping +bpArgtypeList ps == + bpTuple(ps,function bpSimpleMapping) ++ Parse a mapping expression ++ Mapping: ++ ArgtypeList -> Application -bpMapping() == - bpParenthesized function bpArgtypeList and - bpEqKey "ARROW" and bpApplication() and - bpPush %Mapping(bpPop1(), bfUntuple bpPop1()) +bpMapping ps == + bpParenthesized(ps,function bpArgtypeList) and + bpEqKey "ARROW" and bpApplication ps and + bpPush(ps,%Mapping(bpPop1(), bfUntuple bpPop1())) bpCancel()== a := bpState() @@ -548,227 +581,230 @@ bpExceptions()== or bpEqPeek "BACKSET" -bpSexpKey()== +bpSexpKey ps == tokenClass $stok = "KEY" and not bpExceptions() => a := $ttok has SHOEINF - a = nil => bpPush keywordId $ttok and bpNext() - bpPush a and bpNext() + a = nil => bpPush(ps,keywordId $ttok) and bpNext() + bpPush(ps,a) and bpNext() false -bpAnyId()== +bpAnyId ps == bpEqKey "MINUS" and (tokenClass $stok = "INTEGER" or bpTrap()) and - bpPush(-$ttok) and bpNext() or - bpSexpKey() or + bpPush(ps,-$ttok) and bpNext() or + bpSexpKey ps or tokenClass $stok in '(ID INTEGER STRING FLOAT) - and bpPush $ttok and bpNext() - -bpSexp()== - bpAnyId() or - bpEqKey "QUOTE" and bpRequire function bpSexp - and bpPush bfSymbol bpPop1() or - bpIndentParenthesized function bpSexp1 - -bpSexp1()== bpFirstTok() and - bpSexp() and - (bpEqKey "DOT" and bpSexp() and bpPush [bpPop2(),:bpPop1()] or - bpSexp1() and bpPush [bpPop2(),:bpPop1()]) or - bpPush nil - -bpPrimary1() == - bpParenthesizedApplication() or - bpDot() or - bpConstTok() or - bpConstruct() or - bpCase() or - bpStruct() or - bpPDefinition() or - bpBPileDefinition() - -bpParenthesizedApplication() == - bpName() and bpAnyNo function bpArgumentList - -bpArgumentList() == - bpPDefinition() and - bpPush bfApplication(bpPop2(), bpPop1()) - -bpPrimary()== bpFirstTok() and (bpPrimary1() or bpPrefixOperator()) - -bpDot()== bpEqKey "DOT" and bpPush bfDot () - -bpPrefixOperator()== + and bpPush(ps,$ttok) and bpNext() + +bpSexp ps == + bpAnyId ps or + bpEqKey "QUOTE" and bpRequire(ps,function bpSexp) + and bpPush(ps,bfSymbol bpPop1()) or + bpIndentParenthesized(ps,function bpSexp1) + +bpSexp1 ps == bpFirstTok() and + bpSexp ps and + (bpEqKey "DOT" and bpSexp ps and bpPush(ps,[bpPop2(),:bpPop1()]) or + bpSexp1 ps and bpPush(ps,[bpPop2(),:bpPop1()])) 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(), bpPop1())) + +bpPrimary ps == + bpFirstTok() and (bpPrimary1 ps or bpPrefixOperator ps ) + +bpDot ps == + bpEqKey "DOT" and bpPush(ps,bfDot()) + +bpPrefixOperator ps == tokenClass $stok = "KEY" and - $ttok has SHOEPRE and bpPushId() and bpNext() + $ttok has SHOEPRE and bpPushId ps and bpNext() -bpInfixOperator()== +bpInfixOperator ps == tokenClass $stok = "KEY" and - $ttok has SHOEINF and bpPushId() and bpNext() + $ttok has SHOEINF and bpPushId ps and bpNext() -bpSelector()== - bpEqKey "DOT" and (bpPrimary() - and bpPush(bfElt(bpPop2(),bpPop1())) - or bpPush bfSuffixDot bpPop1() ) +bpSelector ps == + bpEqKey "DOT" and (bpPrimary ps + and bpPush(ps,bfElt(bpPop2(),bpPop1())) + or bpPush(ps,bfSuffixDot bpPop1())) -bpApplication()== - bpPrimary() and bpAnyNo function bpSelector and - (bpApplication() and - bpPush(bfApplication(bpPop2(),bpPop1())) or true) - or bpNamespace() +bpApplication ps== + bpPrimary ps and bpAnyNo(ps,function bpSelector) and + (bpApplication ps and + bpPush(ps,bfApplication(bpPop2(),bpPop1())) or true) + or bpNamespace ps ++ Typing: ++ SimpleType ++ Mapping ++ FORALL Variable DOT Typing -bpTyping() == +bpTyping ps == bpEqKey "FORALL" => - bpRequire function bpVariable - (bpDot() and bpPop1()) or bpTrap() - bpRequire function bpTyping - bpPush %Forall(bpPop2(), bpPop1()) - bpMapping() or bpSimpleMapping() + bpRequire(ps,function bpVariable) + (bpDot ps and bpPop1()) or bpTrap() + bpRequire(ps,function bpTyping) + bpPush(ps,%Forall(bpPop2(), bpPop1())) + bpMapping ps or bpSimpleMapping ps ++ Typed: ++ Application : Typing ++ Application @ Typing -bpTyped()== - bpApplication() and +bpTyped ps == + bpApplication ps and bpEqKey "COLON" => - bpRequire function bpTyping and - bpPush bfTagged(bpPop2(),bpPop1()) + bpRequire(ps,function bpTyping) and + bpPush(ps,bfTagged(bpPop2(),bpPop1())) bpEqKey "AT" => - bpRequire function bpTyping and - bpPush bfRestrict(bpPop2(), bpPop1()) + bpRequire(ps,function bpTyping) and + bpPush(ps,bfRestrict(bpPop2(), bpPop1())) true -bpExpt()== bpRightAssoc('(POWER),function bpTyped) +bpExpt ps == bpRightAssoc(ps,'(POWER),function bpTyped) -bpInfKey s == +bpInfKey(ps,s) == tokenClass $stok = "KEY" and - symbolMember?($ttok,s) and bpPushId() and bpNext() + symbolMember?($ttok,s) and bpPushId ps and bpNext() -bpInfGeneric s== - bpInfKey s and (bpEqKey "BACKSET" or true) +bpInfGeneric(ps,s) == + bpInfKey(ps,s) and (bpEqKey "BACKSET" or true) -bpRightAssoc(o,p)== +bpRightAssoc(ps,o,p)== a := bpState() - apply(p,nil) => - while bpInfGeneric o and (bpRightAssoc(o,p) or bpTrap()) repeat - bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) + apply(p,ps,nil) => + while bpInfGeneric(ps,o) and (bpRightAssoc(ps,o,p) or bpTrap()) repeat + bpPush(ps,bfInfApplication(bpPop2(),bpPop2(),bpPop1())) true bpRestore a false -bpLeftAssoc(operations,parser)== - apply(parser,nil) => - while bpInfGeneric(operations) and bpRequire parser +bpLeftAssoc(ps,operations,parser)== + apply(parser,ps,nil) => + while bpInfGeneric(ps,operations) and bpRequire(ps,parser) repeat - bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) + bpPush(ps,bfInfApplication(bpPop2(),bpPop2(),bpPop1())) true false -bpString()== +bpString ps == tokenClass $stok = "STRING" and - bpPush(quote makeSymbol $ttok) and bpNext() + bpPush(ps,quote makeSymbol $ttok) and bpNext() -bpFunction() == - bpEqKey "FUNCTION" and bpRequire function bpPrimary1 - and bpPush bfFunction bpPop1() +bpFunction ps == + bpEqKey "FUNCTION" and bpRequire(ps,function bpPrimary1) + and bpPush(ps,bfFunction bpPop1()) -bpThetaName() == +bpThetaName ps == tokenClass $stok = "ID" and $ttok has SHOETHETA => - bpPushId() + bpPushId ps bpNext() false -bpReduceOperator()== - bpInfixOperator() or bpString() or bpThetaName() +bpReduceOperator ps == + bpInfixOperator ps or bpString ps or bpThetaName ps -bpReduce()== +bpReduce ps== a := bpState() - bpReduceOperator() and bpEqKey "SLASH" => + bpReduceOperator ps and bpEqKey "SLASH" => bpEqPeek "OBRACK" => - bpRequire function bpDConstruct and - bpPush bfReduceCollect(bpPop2(),bpPop1()) - bpRequire function bpApplication and - bpPush bfReduce(bpPop2(),bpPop1()) + bpRequire(ps,function bpDConstruct) and + bpPush(ps,bfReduceCollect(bpPop2(),bpPop1())) + bpRequire(ps,function bpApplication) and + bpPush(ps,bfReduce(bpPop2(),bpPop1())) bpRestore a false -bpTimes()== - bpReduce() or bpLeftAssoc('(TIMES SLASH),function bpExpt) +bpTimes ps == + bpReduce ps or bpLeftAssoc(ps,'(TIMES SLASH),function bpExpt) -bpEuclid() == - bpLeftAssoc('(QUO REM),function bpTimes) +bpEuclid ps == + bpLeftAssoc(ps,'(QUO REM),function bpTimes) -bpMinus()== - bpInfGeneric '(MINUS) and bpRequire function bpEuclid - and bpPush(bfApplication(bpPop2(),bpPop1())) - or bpEuclid() +bpMinus ps == + bpInfGeneric(ps,'(MINUS)) and bpRequire(ps,function bpEuclid) + and bpPush(ps,bfApplication(bpPop2(),bpPop1())) + or bpEuclid ps -bpArith()==bpLeftAssoc('(PLUS MINUS),function bpMinus) +bpArith ps == + bpLeftAssoc(ps,'(PLUS MINUS),function bpMinus) -bpIs()== - bpArith() and - bpInfKey '(IS ISNT) and bpRequire function bpPattern => - bpPush bfISApplication(bpPop2(),bpPop2(),bpPop1()) - bpEqKey "HAS" and bpRequire function bpApplication => - bpPush bfHas(bpPop2(), bpPop1()) +bpIs ps == + bpArith ps and + bpInfKey(ps,'(IS ISNT)) and bpRequire(ps,function bpPattern) => + bpPush(ps,bfISApplication(bpPop2(),bpPop2(),bpPop1())) + bpEqKey "HAS" and bpRequire(ps,function bpApplication) => + bpPush(ps,bfHas(bpPop2(), bpPop1())) true -bpBracketConstruct(f)== - bpBracket f and bpPush bfConstruct bpPop1() +bpBracketConstruct(ps,f)== + bpBracket(ps,f) and bpPush(ps,bfConstruct bpPop1()) -bpCompare()== - bpIs() and (bpInfKey '(SHOEEQ SHOENE LT LE GT GE IN) - and bpRequire function bpIs - and bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) +bpCompare ps == + bpIs ps and (bpInfKey(ps,'(SHOEEQ SHOENE LT LE GT GE IN)) + and bpRequire(ps,function bpIs) + and bpPush(ps,bfInfApplication(bpPop2(),bpPop2(),bpPop1())) or true) - or bpLeave() - or bpThrow() + or bpLeave ps + or bpThrow ps -bpAnd() == - bpLeftAssoc('(AND),function bpCompare) +bpAnd ps == + bpLeftAssoc(ps,'(AND),function bpCompare) -bpThrow() == - bpEqKey "THROW" and bpApplication() => +bpThrow ps == + bpEqKey "THROW" and bpApplication ps => -- Allow user-supplied matching type tag if bpEqKey "COLON" then - bpRequire function bpApplication - bpPush %Pretend(bpPop2(),bpPop1()) - bpPush bfThrow bpPop1() + bpRequire(ps,function bpApplication) + bpPush(ps,%Pretend(bpPop2(),bpPop1())) + bpPush(ps,bfThrow bpPop1()) nil ++ Try: ++ try Assign CatchItems -bpTry() == +bpTry ps == bpEqKey "TRY" => - bpAssign() + bpAssign ps cs := [] while bpHandler "CATCH" repeat - bpCatchItem() + bpCatchItem ps cs := [bpPop1(),:cs] bpHandler "FINALLY" => - bpFinally() and - bpPush bfTry(bpPop2(),reverse! [bpPop1(),:cs]) + bpFinally ps and + bpPush(ps,bfTry(bpPop2(),reverse! [bpPop1(),:cs])) cs = nil => bpTrap() -- missing handlers - bpPush bfTry(bpPop1(),reverse! cs) + bpPush(ps,bfTry(bpPop1(),reverse! cs)) nil -bpCatchItem() == - bpRequire function bpExceptionVariable and +bpCatchItem ps == + bpRequire(ps,function bpExceptionVariable) and (bpEqKey "EXIT" or bpTrap()) and - bpRequire function bpAssign and - bpPush %Catch(bpPop2(),bpPop1()) + bpRequire(ps,function bpAssign) and + bpPush(ps,%Catch(bpPop2(),bpPop1())) -bpExceptionVariable() == +bpExceptionVariable ps == t := $stok bpEqKey "OPAREN" and - bpRequire function bpSignature and + bpRequire(ps,function bpSignature) and (bpEqKey "CPAREN" or bpMissing t) or bpTrap() -bpFinally() == - bpRequire function bpAssign and - bpPush %Finally bpPop1() +bpFinally ps == + bpRequire(ps,function bpAssign) and + bpPush(ps,%Finally bpPop1()) bpHandler key == s := bpState() @@ -778,145 +814,150 @@ bpHandler key == ++ Leave: ++ LEAVE Logical -bpLeave() == - bpEqKey "LEAVE" and bpRequire function bpLogical and - bpPush bfLeave bpPop1() +bpLeave ps == + bpEqKey "LEAVE" and bpRequire(ps,function bpLogical) and + bpPush(ps,bfLeave bpPop1()) ++ Do: ++ IN Namespace Do ++ DO Assign -bpDo() == +bpDo ps == bpEqKey "IN" => - bpRequire function bpNamespace - bpRequire function bpDo - bpPush bfAtScope(bpPop2(),bpPop1()) - bpEqKey "DO" and bpRequire function bpAssign and - bpPush bfDo bpPop1() + bpRequire(ps,function bpNamespace) + bpRequire(ps,function bpDo) + bpPush(ps,bfAtScope(bpPop2(),bpPop1())) + bpEqKey "DO" and bpRequire(ps,function bpAssign) and + bpPush(ps,bfDo bpPop1()) ++ Return: ++ RETURN Assign ++ Leave ++ Throw ++ And -bpReturn()== - (bpEqKey "RETURN" and bpRequire function bpAssign and - bpPush bfReturnNoName bpPop1()) - or bpLeave() - or bpThrow() - or bpAnd() - or bpDo() - - -bpLogical()== bpLeftAssoc('(OR),function bpReturn) - -bpExpression()== - bpEqKey "COLON" and (bpLogical() and - bpPush bfApplication ("COLON",bpPop1()) - or bpTrap()) or bpLogical() - -bpStatement()== - bpConditional function bpWhere or bpLoop() - or bpExpression() - or bpTry() - -bpLoop()== - bpIterators() and +bpReturn ps== + (bpEqKey "RETURN" and bpRequire(ps,function bpAssign) and + bpPush(ps,bfReturnNoName bpPop1())) + or bpLeave ps + or bpThrow ps + or bpAnd ps + or bpDo ps + + +bpLogical ps == + bpLeftAssoc(ps,'(OR),function bpReturn) + +bpExpression ps == + bpEqKey "COLON" and (bpLogical ps and + bpPush(ps,bfApplication ("COLON",bpPop1())) + or bpTrap()) or bpLogical ps + +bpStatement ps == + bpConditional(ps,function bpWhere) or bpLoop ps + or bpExpression ps + or bpTry ps + +bpLoop ps == + bpIterators ps and (bpCompMissing "REPEAT" and - bpRequire function bpWhere and - bpPush bfLp(bpPop2(),bpPop1())) + bpRequire(ps,function bpWhere) and + bpPush(ps,bfLp(bpPop2(),bpPop1()))) or - bpEqKey "REPEAT" and bpRequire function bpLogical and - bpPush bfLoop1 bpPop1 () + bpEqKey "REPEAT" and bpRequire(ps,function bpLogical) and + bpPush(ps,bfLoop1 bpPop1()) -bpSuchThat()==bpAndOr("BAR",function bpWhere,function bfSuchthat) +bpSuchThat ps == + bpAndOr(ps,"BAR",function bpWhere,function bfSuchthat) -bpWhile()==bpAndOr ("WHILE",function bpLogical,function bfWhile) +bpWhile ps == + bpAndOr(ps,"WHILE",function bpLogical,function bfWhile) -bpUntil()==bpAndOr ("UNTIL",function bpLogical,function bfUntil) +bpUntil ps == + bpAndOr(ps,"UNTIL",function bpLogical,function bfUntil) -bpFormal() == - bpVariable() or bpDot() +bpFormal ps == + bpVariable ps or bpDot ps -bpForIn()== - bpEqKey "FOR" and bpRequire function bpFormal and (bpCompMissing "IN") - and (bpRequire function bpSeg and - (bpEqKey "BY" and bpRequire function bpArith and - bpPush bfForInBy(bpPop3(),bpPop2(),bpPop1())) or - bpPush bfForin(bpPop2(),bpPop1())) +bpForIn ps == + bpEqKey "FOR" and bpRequire(ps,function bpFormal) and (bpCompMissing "IN") + and (bpRequire(ps,function bpSeg) and + (bpEqKey "BY" and bpRequire(ps,function bpArith) and + bpPush(ps,bfForInBy(bpPop3(),bpPop2(),bpPop1()))) or + bpPush(ps,bfForin(bpPop2(),bpPop1()))) -bpSeg()== - bpArith() and +bpSeg ps == + bpArith ps and (bpEqKey "SEG" and - (bpArith() and bpPush(bfSegment2(bpPop2(),bpPop1())) - or bpPush(bfSegment1(bpPop1()))) or true) + (bpArith ps and bpPush(ps,bfSegment2(bpPop2(),bpPop1())) + or bpPush(ps,bfSegment1(bpPop1()))) or true) -bpIterator()== - bpForIn() or bpSuchThat() or bpWhile() or bpUntil() +bpIterator ps == + bpForIn ps or bpSuchThat ps or bpWhile ps or bpUntil ps -bpIteratorList()== - bpOneOrMore function bpIterator - and bpPush bfIterators bpPop1 () +bpIteratorList ps == + bpOneOrMore(ps,function bpIterator) + and bpPush(ps,bfIterators bpPop1()) -bpCrossBackSet()== +bpCrossBackSet ps == bpEqKey "CROSS" and (bpEqKey "BACKSET" or true) -bpIterators()== - bpListofFun(function bpIteratorList, +bpIterators ps == + bpListofFun(ps,function bpIteratorList, function bpCrossBackSet,function bfCross) -bpAssign()== +bpAssign ps == a := bpState() - bpStatement() => + bpStatement ps => bpEqPeek "BEC" => bpRestore a - bpRequire function bpAssignment + bpRequire(ps,function bpAssignment) bpEqPeek "GIVES" => bpRestore a - bpRequire function bpLambda + bpRequire(ps,function bpLambda) bpEqPeek "LARROW" => bpRestore a - bpRequire function bpKeyArg + bpRequire(ps,function bpKeyArg) true bpRestore a false -bpAssignment()== - bpAssignVariable() and +bpAssignment ps == + bpAssignVariable ps and bpEqKey "BEC" and - bpRequire function bpAssign and - bpPush bfAssign (bpPop2(),bpPop1()) + bpRequire(ps,function bpAssign) and + bpPush(ps,bfAssign(bpPop2(),bpPop1())) ++ Parse a lambda expression ++ Lambda ::= Variable +-> Assign -bpLambda() == - bpVariable() and +bpLambda ps == + bpVariable ps and bpEqKey "GIVES" and - bpRequire function bpAssign and - bpPush bfLambda(bpPop2(),bpPop1()) + bpRequire(ps,function bpAssign) and + bpPush(ps,bfLambda(bpPop2(),bpPop1())) -bpKeyArg() == - bpName() and bpEqKey "LARROW" and bpLogical() and - bpPush bfKeyArg(bpPop2(),bpPop1()) +bpKeyArg ps == + bpName ps and bpEqKey "LARROW" and bpLogical ps and + bpPush(ps,bfKeyArg(bpPop2(),bpPop1())) -- should only be allowed in sequences -bpExit()== - bpAssign() and (bpEqKey "EXIT" and - (bpRequire function bpWhere and - bpPush bfExit (bpPop2(),bpPop1())) +bpExit ps == + bpAssign ps and (bpEqKey "EXIT" and + (bpRequire(ps,function bpWhere) and + bpPush(ps,bfExit(bpPop2(),bpPop1()))) or true) -bpDefinition()== +bpDefinition ps == bpEqKey "MACRO" => - bpName() and bpStoreName() and bpCompoundDefinitionTail function %Macro - or bpTrap() + bpName ps and bpStoreName() and + bpCompoundDefinitionTail(ps,function %Macro) + or bpTrap() a := bpState() - bpExit() => + bpExit ps => bpEqPeek "DEF" => bpRestore a - bpDef() + bpDef ps bpEqPeek "TDEF" => bpRestore a - bpTypeAliasDefition() + bpTypeAliasDefition ps true bpRestore a false @@ -927,157 +968,158 @@ bpStoreName()== $typings := nil true -bpDef() == - bpName() and bpStoreName() and bpDefTail function %Definition - or bpNamespace() and bpSimpleDefinitionTail() +bpDef ps == + bpName ps and bpStoreName() and bpDefTail(ps,function %Definition) + or bpNamespace ps and bpSimpleDefinitionTail ps -bpDDef() == bpName() and bpDefTail function %Definition +bpDDef ps == + bpName ps and bpDefTail(ps,function %Definition) ++ Parse the remaining of a simple definition. -bpSimpleDefinitionTail() == +bpSimpleDefinitionTail ps == bpEqKey "DEF" and - bpRequire function bpWhere - and bpPush %ConstantDefinition(bpPop2(), bpPop1()) + bpRequire(ps,function bpWhere) + and bpPush(ps,%ConstantDefinition(bpPop2(), bpPop1())) ++ Parse the remaining of a compound definition. -bpCompoundDefinitionTail f == - bpVariable() and - bpEqKey "DEF" and bpRequire function bpWhere and - bpPush apply(f,[bpPop3(),bpPop2(),bpPop1()]) +bpCompoundDefinitionTail(ps,f) == + bpVariable ps and + bpEqKey "DEF" and bpRequire(ps,function bpWhere) and + bpPush(ps,apply(f,[bpPop3(),bpPop2(),bpPop1()])) ++ 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 f == - bpSimpleDefinitionTail() - or bpCompoundDefinitionTail f +bpDefTail(ps,f) == + bpSimpleDefinitionTail ps + or bpCompoundDefinitionTail(ps,f) -bpWhere()== - bpDefinition() and - (bpEqKey "WHERE" and bpRequire function bpDefinitionItem - and bpPush bfWhere(bpPop1(),bpPop1()) or true) +bpWhere ps == + bpDefinition ps and + (bpEqKey "WHERE" and bpRequire(ps,function bpDefinitionItem) + and bpPush(ps,bfWhere(bpPop1(),bpPop1())) or true) -bpDefinitionItem()== +bpDefinitionItem ps == a := bpState() - bpDDef() => true + bpDDef ps => true bpRestore a - bpBDefinitionPileItems() => true + bpBDefinitionPileItems ps => true bpRestore a - bpPDefinitionItems() => true + bpPDefinitionItems ps => true bpRestore a - bpWhere() + bpWhere ps -bpDefinitionPileItems()== - bpListAndRecover function bpDefinitionItem - and bpPush %Pile bpPop1() +bpDefinitionPileItems ps == + bpListAndRecover(ps,function bpDefinitionItem) + and bpPush(ps,%Pile bpPop1()) -bpBDefinitionPileItems()== bpPileBracketed function bpDefinitionPileItems +bpBDefinitionPileItems ps == + bpPileBracketed(ps,function bpDefinitionPileItems) -bpSemiColonDefinition()==bpSemiListing - (function bpDefinitionItem,function %Pile) +bpSemiColonDefinition ps == + bpSemiListing(ps,function bpDefinitionItem,function %Pile) -bpPDefinitionItems()== - bpParenthesized function bpSemiColonDefinition +bpPDefinitionItems ps == + bpParenthesized(ps,function bpSemiColonDefinition) -bpComma()== - bpModule() or bpImport() or bpTuple function bpWhere +bpComma ps == + bpModule ps or bpImport ps or bpTuple(ps,function bpWhere) -bpTuple(p) == - bpListofFun(p,function bpCommaBackSet,function bfTuple) +bpTuple(ps,p) == + bpListofFun(ps,p,function bpCommaBackSet,function bfTuple) -bpCommaBackSet() == +bpCommaBackSet ps == bpEqKey "COMMA" and (bpEqKey "BACKSET" or true) -bpSemiColon() == - bpSemiListing (function bpComma,function bfSequence) +bpSemiColon ps == + bpSemiListing(ps,function bpComma,function bfSequence) -bpSemiListing(p,f) == - bpListofFun(p,function bpSemiBackSet,f) +bpSemiListing(ps,p,f) == + bpListofFun(ps,p,function bpSemiBackSet,f) -bpSemiBackSet()== +bpSemiBackSet ps == bpEqKey "SEMICOLON" and (bpEqKey "BACKSET" or true) -bpPDefinition()== - bpIndentParenthesized function bpSemiColon +bpPDefinition ps == + bpIndentParenthesized(ps,function bpSemiColon) -bpPileItems()== - bpListAndRecover function bpSemiColon and bpPush bfSequence bpPop1() +bpPileItems ps == + bpListAndRecover(ps,function bpSemiColon) and bpPush(ps,bfSequence bpPop1()) -bpBPileDefinition()== - bpPileBracketed function bpPileItems +bpBPileDefinition ps == + bpPileBracketed(ps,function bpPileItems) -bpIteratorTail()== - (bpEqKey "REPEAT" or true) and bpIterators() +bpIteratorTail ps == + (bpEqKey "REPEAT" or true) and bpIterators ps -bpConstruct()== - bpBracket function bpConstruction +bpConstruct ps == + bpBracket(ps,function bpConstruction) -bpConstruction()== - bpComma() and - (bpIteratorTail() and - bpPush bfCollect (bpPop2(),bpPop1()) or - bpPush bfTupleConstruct bpPop1()) +bpConstruction ps== + bpComma ps and + (bpIteratorTail ps and + bpPush(ps,bfCollect(bpPop2(),bpPop1())) or + bpPush(ps,bfTupleConstruct bpPop1())) -bpDConstruct()== - bpBracket function bpDConstruction +bpDConstruct ps == + bpBracket(ps,function bpDConstruction) -bpDConstruction()== - bpComma() and - (bpIteratorTail() and - bpPush bfDCollect (bpPop2(),bpPop1()) or - bpPush bfDTuple bpPop1()) +bpDConstruction ps == + bpComma ps and + (bpIteratorTail ps and + bpPush(ps,bfDCollect(bpPop2(),bpPop1())) or + bpPush(ps,bfDTuple bpPop1())) --PATTERN ---bpNameOrDot() == bpName() or bpDot() or bpEqual() +bpPattern ps == + bpBracketConstruct(ps,function bpPatternL) + or bpChar ps or bpName ps or bpConstTok ps -bpPattern()== - bpBracketConstruct function bpPatternL - or bpChar() or bpName() or bpConstTok() +bpEqual ps == + bpEqKey "SHOEEQ" and (bpApplication ps or bpConstTok ps or + bpTrap()) and bpPush(ps,bfEqual bpPop1()) -bpEqual()== - bpEqKey "SHOEEQ" and (bpApplication() or bpConstTok() or - bpTrap()) and bpPush bfEqual bpPop1() +bpRegularPatternItem ps == + bpEqual ps or + bpConstTok ps or bpDot ps or + bpName ps and + ((bpEqKey "BEC" and bpRequire(ps,function bpPattern) + and bpPush(ps,bfAssign(bpPop2(),bpPop1()))) or true) + or bpBracketConstruct(ps,function bpPatternL) -bpRegularPatternItem() == - bpEqual() or - bpConstTok() or bpDot() or - bpName() and - ((bpEqKey "BEC" and bpRequire function bpPattern - and bpPush bfAssign(bpPop2(),bpPop1())) or true) - or bpBracketConstruct function bpPatternL +bpRegularPatternItemL ps == + bpRegularPatternItem ps and bpPush(ps,[bpPop1()]) -bpRegularPatternItemL()== - bpRegularPatternItem() and bpPush [bpPop1()] +bpRegularList ps == + bpListof(ps,function bpRegularPatternItemL,"COMMA",function bfAppend) -bpRegularList()== - bpListof(function bpRegularPatternItemL,"COMMA",function bfAppend) - -bpPatternColon()== - bpEqKey "COLON" and bpRequire function bpRegularPatternItem - and bpPush [bfColon bpPop1()] +bpPatternColon ps == + bpEqKey "COLON" and bpRequire(ps,function bpRegularPatternItem) + and bpPush(ps,[bfColon bpPop1()]) -- only one colon -bpPatternL() == bpPatternList() and bpPush bfTuple bpPop1() - -bpPatternList()== - bpRegularPatternItemL() => - while (bpEqKey "COMMA" and (bpRegularPatternItemL() or - (bpPatternTail() - and bpPush append(bpPop2(),bpPop1()) +bpPatternL ps == + bpPatternList ps and bpPush(ps,bfTuple bpPop1()) + +bpPatternList ps == + bpRegularPatternItemL ps => + while (bpEqKey "COMMA" and (bpRegularPatternItemL ps or + (bpPatternTail ps + and bpPush(ps,append(bpPop2(),bpPop1())) or bpTrap();false) )) repeat - bpPush append(bpPop2(),bpPop1()) + bpPush(ps,append(bpPop2(),bpPop1())) true - bpPatternTail() + bpPatternTail ps -bpPatternTail()== - bpPatternColon() and - (bpEqKey "COMMA" and bpRequire function bpRegularList - and bpPush append (bpPop2(),bpPop1()) or true) +bpPatternTail ps == + bpPatternColon ps and + (bpEqKey "COMMA" and bpRequire(ps,function bpRegularList) + and bpPush(ps,append(bpPop2(),bpPop1())) or true) -- BOUND VARIABLE @@ -1086,179 +1128,180 @@ bpPatternTail()== ++ 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() == - bpEqKey "COLON" and bpRequire function bpApplication and - bpPush bfTagged(bpPop2(), bpPop1()) - or bpEqKey "BEC" and bpRequire function bpPattern and - bpPush bfAssign(bpPop2(),bpPop1()) - or bpEqKey "IS" and bpRequire function bpPattern and - bpPush bfAssign(bpPop2(),bpPop1()) - or bpEqKey "DEF" and bpRequire function bpApplication and - bpPush %DefaultValue(bpPop2(), bpPop1()) - - -bpRegularBVItem() == - bpBVString() - or bpConstTok() - or (bpName() and (bpRegularBVItemTail() or true)) - or bpBracketConstruct function bpPatternL - -bpBVString()== +bpRegularBVItemTail ps == + bpEqKey "COLON" and bpRequire(ps,function bpApplication) and + bpPush(ps,bfTagged(bpPop2(), bpPop1())) + or bpEqKey "BEC" and bpRequire(ps,function bpPattern) and + bpPush(ps,bfAssign(bpPop2(),bpPop1())) + or bpEqKey "IS" and bpRequire(ps,function bpPattern) and + bpPush(ps,bfAssign(bpPop2(),bpPop1())) + or bpEqKey "DEF" and bpRequire(ps,function bpApplication) and + bpPush(ps,%DefaultValue(bpPop2(), bpPop1())) + + +bpRegularBVItem ps == + bpBVString ps + or bpConstTok ps + or (bpName ps and (bpRegularBVItemTail ps or true)) + or bpBracketConstruct(ps,function bpPatternL) + +bpBVString ps == tokenClass $stok = "STRING" and - bpPush(["BVQUOTE",makeSymbol $ttok]) and bpNext() + bpPush(ps,["BVQUOTE",makeSymbol $ttok]) and bpNext() -bpRegularBVItemL() == - bpRegularBVItem() and bpPush [bpPop1()] +bpRegularBVItemL ps == + bpRegularBVItem ps and bpPush(ps,[bpPop1()]) -bpColonName()== - bpEqKey "COLON" and (bpName() or bpBVString() or bpTrap()) +bpColonName ps == + bpEqKey "COLON" and (bpName ps or bpBVString ps or bpTrap()) -- at most one colon at end -bpBoundVariablelist()== - bpRegularBVItemL() => - while (bpEqKey "COMMA" and (bpRegularBVItemL() or - (bpColonName() - and bpPush bfColonAppend(bpPop2(),bpPop1()) +bpBoundVariablelist ps == + bpRegularBVItemL ps => + while (bpEqKey "COMMA" and (bpRegularBVItemL ps or + (bpColonName ps + and bpPush(ps,bfColonAppend(bpPop2(),bpPop1())) or bpTrap();false) )) repeat - bpPush append(bpPop2(),bpPop1()) + bpPush(ps,append(bpPop2(),bpPop1())) true - bpColonName() and bpPush bfColonAppend(nil,bpPop1()) + bpColonName ps and bpPush(ps,bfColonAppend(nil,bpPop1())) -bpVariable()== - bpParenthesized function bpBoundVariablelist and - bpPush bfTupleIf bpPop1() - or bpBracketConstruct function bpPatternL - or bpName() or bpConstTok() +bpVariable ps == + bpParenthesized(ps,function bpBoundVariablelist) and + bpPush(ps,bfTupleIf bpPop1()) + or bpBracketConstruct(ps,function bpPatternL) + or bpName ps or bpConstTok ps -bpAssignVariable()== - bpBracketConstruct function bpPatternL or bpAssignLHS() +bpAssignVariable ps == + bpBracketConstruct(ps,function bpPatternL) or bpAssignLHS ps -bpAssignLHS()== - not bpName() => false +bpAssignLHS ps == + not bpName ps => false bpEqKey "COLON" => -- variable declaration - bpRequire function bpApplication - bpPush bfLocal(bpPop2(),bpPop1()) - bpArgumentList() and + bpRequire(ps,function bpApplication) + bpPush(ps,bfLocal(bpPop2(),bpPop1())) + bpArgumentList ps and (bpEqPeek "DOT" - or (bpEqPeek "BEC" and bpPush bfPlace bpPop1()) + or (bpEqPeek "BEC" and bpPush(ps,bfPlace bpPop1())) or bpTrap()) bpEqKey "DOT" => -- field path - bpList(function bpPrimary,"DOT") and - bpChecknull() and - bpPush bfTuple([bpPop2(),:bpPop1()]) + bpList(ps,function bpPrimary,"DOT") and + bpChecknull ps and + bpPush(ps,bfTuple([bpPop2(),:bpPop1()])) true -bpChecknull()== +bpChecknull ps == a := bpPop1() a = nil => bpTrap() - bpPush a + bpPush(ps,a) -bpStruct()== +bpStruct ps == bpEqKey "STRUCTURE" and - bpRequire function bpName and + bpRequire(ps,function bpName) and (bpEqKey "DEF" or bpTrap()) and - (bpRecord() or bpTypeList()) and - bpPush %Structure(bpPop2(),bpPop1()) + (bpRecord ps or bpTypeList ps) and + bpPush(ps,%Structure(bpPop2(),bpPop1())) ++ Record: ++ "Record" "(" FieldList ")" -bpRecord() == +bpRecord ps == s := bpState() - bpName() and bpPop1() is "Record" => - (bpParenthesized function bpFieldList or bpTrap()) and - bpGlobalAccessors() and - bpPush %Record(bfUntuple bpPop2(),bpPop1()) + bpName ps and bpPop1() is "Record" => + (bpParenthesized(ps,function bpFieldList) or bpTrap()) and + bpGlobalAccessors ps and + bpPush(ps,%Record(bfUntuple bpPop2(),bpPop1())) bpRestore s false ++ FieldList: ++ Signature ++ Signature , FieldList -bpFieldList() == - bpTuple function bpSignature +bpFieldList ps == + bpTuple(ps,function bpSignature) -bpGlobalAccessors() == +bpGlobalAccessors ps == bpEqKey "WITH" => - bpPileBracketed function bpAccessorDefinitionList or bpTrap() - bpPush nil + bpPileBracketed(ps,function bpAccessorDefinitionList) or bpTrap() + bpPush(ps,nil) -bpAccessorDefinitionList() == - bpListAndRecover function bpAccessorDefinition +bpAccessorDefinitionList ps == + bpListAndRecover(ps,function bpAccessorDefinition) ++ AccessorDefinition: ++ Name DEF FieldSection -bpAccessorDefinition() == - bpRequire function bpName and +bpAccessorDefinition ps == + bpRequire(ps,function bpName) and (bpEqKey "DEF" or bpTrap()) and - bpRequire function bpFieldSection and - bpPush %AccessorDef(bpPop2(),bpPop1()) + bpRequire(ps,function bpFieldSection) and + bpPush(ps,%AccessorDef(bpPop2(),bpPop1())) ++ FieldSection: ++ "(" DOT Name ")" -bpFieldSection() == - bpParenthesized function bpSelectField +bpFieldSection ps == + bpParenthesized(ps,function bpSelectField) -bpSelectField() == - bpEqKey "DOT" and bpName() +bpSelectField ps == + bpEqKey "DOT" and bpName ps -bpTypeList() == - bpPileBracketed function bpTypeItemList - or bpTypeItem() and bpPush [bpPop1()] +bpTypeList ps == + bpPileBracketed(ps,function bpTypeItemList) + or bpTypeItem ps and bpPush(ps,[bpPop1()]) -bpTypeItem() == - bpTerm function bpIdList +bpTypeItem ps == + bpTerm(ps,function bpIdList) -bpTypeItemList() == - bpListAndRecover function bpTypeItem +bpTypeItemList ps == + bpListAndRecover(ps,function bpTypeItem) -bpTerm idListParser == - bpRequire function bpName and - ((bpParenthesized idListParser and - bpPush bfNameArgs (bpPop2(),bpPop1())) - or bpName() and bpPush bfNameArgs(bpPop2(),bpPop1())) - or bpPush(bfNameOnly bpPop1()) +bpTerm(ps,idListParser) == + bpRequire(ps,function bpName) and + ((bpParenthesized(ps,idListParser) and + bpPush(ps,bfNameArgs(bpPop2(),bpPop1()))) + or bpName ps and bpPush(ps,bfNameArgs(bpPop2(),bpPop1()))) + or bpPush(ps,bfNameOnly bpPop1()) -bpIdList()== - bpTuple function bpName +bpIdList ps == + bpTuple(ps,function bpName) -bpCase()== +bpCase ps == bpEqKey "CASE" and - bpRequire function bpWhere and + bpRequire(ps,function bpWhere) and (bpEqKey "OF" or bpMissing "OF") and - bpPiledCaseItems() + bpPiledCaseItems ps -bpPiledCaseItems()== - bpPileBracketed function bpCaseItemList and - bpPush bfCase(bpPop2(),bpPop1()) +bpPiledCaseItems ps == + bpPileBracketed(ps,function bpCaseItemList) and + bpPush(ps,bfCase(bpPop2(),bpPop1())) -bpCaseItemList()== - bpListAndRecover function bpCaseItem +bpCaseItemList ps == + bpListAndRecover(ps,function bpCaseItem) -bpCasePatternVar() == - bpName() or bpDot() +bpCasePatternVar ps == + bpName ps or bpDot ps -bpCasePatternVarList() == - bpTuple function bpCasePatternVar +bpCasePatternVarList ps == + bpTuple(ps,function bpCasePatternVar) -bpCaseItem()== - (bpTerm function bpCasePatternVarList or bpTrap()) and +bpCaseItem ps == + (bpTerm(ps,function bpCasePatternVarList) or bpTrap()) and (bpEqKey "EXIT" or bpTrap()) and - bpRequire function bpWhere and - bpPush bfCaseItem (bpPop2(),bpPop1()) + bpRequire(ps,function bpWhere) and + bpPush(ps,bfCaseItem(bpPop2(),bpPop1())) ++ Main entry point into the parser module. -bpOutItem()== +bpOutItem ps == $op: local := nil $GenVarCounter: local := 0 - bpRequire function bpComma + bpRequire(ps,function bpComma) b := bpPop1() - bpPush + t := b is ["+LINE",:.] => [ b ] b is ["L%T",l,r] and symbol? l => $InteractiveMode => [["SETQ",l,r]] [["DEFPARAMETER",l,r]] translateToplevel(b,false) + bpPush(ps,t) diff --git a/src/boot/strap/includer.clisp b/src/boot/strap/includer.clisp index ce957612..3ecb4580 100644 --- a/src/boot/strap/includer.clisp +++ b/src/boot/strap/includer.clisp @@ -20,7 +20,9 @@ (READ-FROM-STRING (CONCAT "(" (|subString| |s| |n| (- |l| |n|)) ")"))))))) -(DEFUN |shoeConsole| (|line|) (WRITE-LINE |line| *TERMINAL-IO*)) +(DEFUN |shoeConsole| (|line|) + (DECLARE (SPECIAL |$stdio|)) + (WRITE-LINE |line| |$stdio|)) (DEFUN |shoeSpaces| (|n|) (|makeString| |n| (|char| '|.|))) diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp index e4862eb5..e876b3ba 100644 --- a/src/boot/strap/parser.clisp +++ b/src/boot/strap/parser.clisp @@ -9,6 +9,50 @@ (PROVIDE "parser") +(DEFSTRUCT (|%ParserState| (:COPIER |copy%ParserState|)) + |toks| + |trees| + |pren| + |scp|) + +(DEFMACRO |mk%ParserState| (|toks| |trees| |pren| |scp|) + (LIST '|MAKE-%ParserState| :|toks| |toks| :|trees| |trees| :|pren| |pren| + :|scp| |scp|)) + +(DEFMACRO |parserTokens| (|bfVar#1|) (LIST '|%ParserState-toks| |bfVar#1|)) + +(DEFMACRO |parserTrees| (|bfVar#1|) (LIST '|%ParserState-trees| |bfVar#1|)) + +(DEFMACRO |parserNesting| (|bfVar#1|) (LIST '|%ParserState-pren| |bfVar#1|)) + +(DEFMACRO |parserScope| (|bfVar#1|) (LIST '|%ParserState-scp| |bfVar#1|)) + +(DEFUN |makeParserState| (|toks|) (|mk%ParserState| |toks| NIL 0 0)) + +(DEFSTRUCT (|%Translator| (:COPIER |copy%Translator|)) + |ipath| + |fdefs| + |sigs| + |xports| + |csts|) + +(DEFMACRO |mk%Translator| (|ipath| |fdefs| |sigs| |xports| |csts|) + (LIST '|MAKE-%Translator| :|ipath| |ipath| :|fdefs| |fdefs| :|sigs| |sigs| + :|xports| |xports| :|csts| |csts|)) + +(DEFMACRO |inputFilePath| (|bfVar#1|) (LIST '|%Translator-ifile| |bfVar#1|)) + +(DEFMACRO |functionDefinitions| (|bfVar#1|) + (LIST '|%Translator-fdefs| |bfVar#1|)) + +(DEFMACRO |globalSignatures| (|bfVar#1|) (LIST '|%Translator-sigs| |bfVar#1|)) + +(DEFMACRO |exportedNames| (|bfVar#1|) (LIST '|%Translator-xports| |bfVar#1|)) + +(DEFMACRO |constantBindings| (|bfVar#1|) (LIST '|%Translator-csts| |bfVar#1|)) + +(DEFUN |makeTranslator| (|ip|) (|mk%Translator| |ip| NIL NIL NIL NIL)) + (DEFUN |bpFirstToken| () (DECLARE (SPECIAL |$ttok| |$stok| |$inputStream|)) (PROGN @@ -45,7 +89,7 @@ (DECLARE (SPECIAL |$inputStream|)) (PROGN (SETQ |$inputStream| (CDR |$inputStream|)) (|bpFirstToken|))) -(DEFUN |bpRequire| (|f|) (OR (APPLY |f| NIL) (|bpTrap|))) +(DEFUN |bpRequire| (|ps| |f|) (OR (APPLY |f| |ps| NIL) (|bpTrap|))) (DEFUN |bpState| () (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| |$inputStream|)) @@ -61,11 +105,11 @@ (SETQ |$bpCount| (CADDDR |x|)) T)) -(DEFUN |bpPush| (|x|) +(DEFUN |bpPush| (|ps| |x|) (DECLARE (SPECIAL |$stack|)) (SETQ |$stack| (CONS |x| |$stack|))) -(DEFUN |bpPushId| () +(DEFUN |bpPushId| (|ps|) (DECLARE (SPECIAL |$stack| |$ttok|)) (SETQ |$stack| (CONS (|bfReName| |$ttok|) |$stack|))) @@ -87,7 +131,7 @@ (RPLACD (CDR |$stack|) (CDDDR |$stack|)) |a|))) -(DEFUN |bpIndentParenthesized| (|f|) +(DEFUN |bpIndentParenthesized| (|ps| |f|) (LET* (|a|) (DECLARE (SPECIAL |$inputStream| |$bpParenCount| |$stok|)) (LET ((|$bpCount| 0)) @@ -98,7 +142,7 @@ ((|bpEqPeek| 'OPAREN) (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) (|bpNext|) (COND - ((AND (APPLY |f| NIL) (|bpFirstTok|) + ((AND (APPLY |f| |ps| NIL) (|bpFirstTok|) (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|))) (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|) (COND ((EQL |$bpCount| 0) T) @@ -107,12 +151,12 @@ (|append| (|bpAddTokens| |$bpCount|) |$inputStream|)) (|bpFirstToken|) (COND ((EQL |$bpParenCount| 0) (|bpCancel|) T) (T T))))) - ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL)) + ((|bpEqPeek| 'CPAREN) (|bpPush| |ps| (|bfTuple| NIL)) (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpNextToken|) T) (T (|bpParenTrap| |a|)))) (T NIL)))))) -(DEFUN |bpParenthesized| (|f|) +(DEFUN |bpParenthesized| (|ps| |f|) (LET* (|a|) (DECLARE (SPECIAL |$stok|)) (PROGN @@ -120,12 +164,14 @@ (COND ((|bpEqKey| 'OPAREN) (COND - ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) T) - ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T) + ((AND (APPLY |f| |ps| NIL) + (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) + T) + ((|bpEqKey| 'CPAREN) (|bpPush| |ps| (|bfTuple| NIL)) T) (T (|bpParenTrap| |a|)))) (T NIL))))) -(DEFUN |bpBracket| (|f|) +(DEFUN |bpBracket| (|ps| |f|) (LET* (|a|) (DECLARE (SPECIAL |$stok|)) (PROGN @@ -133,110 +179,118 @@ (COND ((|bpEqKey| 'OBRACK) (COND - ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|))) - (|bpPush| (|bfBracket| (|bpPop1|)))) - ((|bpEqKey| 'CBRACK) (|bpPush| NIL)) (T (|bpBrackTrap| |a|)))) + ((AND (APPLY |f| |ps| NIL) + (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|))) + (|bpPush| |ps| (|bfBracket| (|bpPop1|)))) + ((|bpEqKey| 'CBRACK) (|bpPush| |ps| NIL)) (T (|bpBrackTrap| |a|)))) (T NIL))))) -(DEFUN |bpPileBracketed| (|f|) +(DEFUN |bpPileBracketed| (|ps| |f|) (COND ((|bpEqKey| 'SETTAB) (COND ((|bpEqKey| 'BACKTAB) T) - ((AND (APPLY |f| NIL) (OR (|bpEqKey| 'BACKTAB) (|bpPileTrap|))) - (|bpPush| (|bfPile| (|bpPop1|)))) + ((AND (APPLY |f| |ps| NIL) (OR (|bpEqKey| 'BACKTAB) (|bpPileTrap|))) + (|bpPush| |ps| (|bfPile| (|bpPop1|)))) (T NIL))) (T NIL))) -(DEFUN |bpListof| (|f| |str1| |g|) +(DEFUN |bpListof| (|ps| |f| |str1| |g|) (LET* (|a|) (DECLARE (SPECIAL |$stack|)) (COND - ((APPLY |f| NIL) + ((APPLY |f| |ps| NIL) (COND - ((AND (|bpEqKey| |str1|) (|bpRequire| |f|)) (SETQ |a| |$stack|) + ((AND (|bpEqKey| |str1|) (|bpRequire| |ps| |f|)) (SETQ |a| |$stack|) (SETQ |$stack| NIL) (LOOP - (COND ((NOT (AND (|bpEqKey| |str1|) (|bpRequire| |f|))) (RETURN NIL)) - (T 0))) + (COND + ((NOT (AND (|bpEqKey| |str1|) (|bpRequire| |ps| |f|))) (RETURN NIL)) + (T NIL))) (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|)) - (|bpPush| - (FUNCALL |g| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) + (|bpPush| |ps| + (FUNCALL |g| + (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) (T T))) (T NIL)))) -(DEFUN |bpListofFun| (|f| |h| |g|) +(DEFUN |bpListofFun| (|ps| |f| |h| |g|) (LET* (|a|) (DECLARE (SPECIAL |$stack|)) (COND - ((APPLY |f| NIL) + ((APPLY |f| |ps| NIL) (COND - ((AND (APPLY |h| NIL) (|bpRequire| |f|)) (SETQ |a| |$stack|) + ((AND (APPLY |h| |ps| NIL) (|bpRequire| |ps| |f|)) (SETQ |a| |$stack|) (SETQ |$stack| NIL) (LOOP - (COND ((NOT (AND (APPLY |h| NIL) (|bpRequire| |f|))) (RETURN NIL)) - (T 0))) + (COND + ((NOT (AND (APPLY |h| |ps| NIL) (|bpRequire| |ps| |f|))) + (RETURN NIL)) + (T NIL))) (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|)) - (|bpPush| - (FUNCALL |g| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) + (|bpPush| |ps| + (FUNCALL |g| + (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) (T T))) (T NIL)))) -(DEFUN |bpList| (|f| |str1|) +(DEFUN |bpList| (|ps| |f| |str1|) (LET* (|a|) (DECLARE (SPECIAL |$stack|)) (COND - ((APPLY |f| NIL) + ((APPLY |f| |ps| NIL) (COND - ((AND (|bpEqKey| |str1|) (|bpRequire| |f|)) (SETQ |a| |$stack|) + ((AND (|bpEqKey| |str1|) (|bpRequire| |ps| |f|)) (SETQ |a| |$stack|) (SETQ |$stack| NIL) (LOOP - (COND ((NOT (AND (|bpEqKey| |str1|) (|bpRequire| |f|))) (RETURN NIL)) - (T 0))) + (COND + ((NOT (AND (|bpEqKey| |str1|) (|bpRequire| |ps| |f|))) (RETURN NIL)) + (T NIL))) (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|)) - (|bpPush| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))) - (T (|bpPush| (LIST (|bpPop1|)))))) - (T (|bpPush| NIL))))) + (|bpPush| |ps| (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|))))) + (T (|bpPush| |ps| (LIST (|bpPop1|)))))) + (T (|bpPush| |ps| NIL))))) -(DEFUN |bpOneOrMore| (|f|) +(DEFUN |bpOneOrMore| (|ps| |f|) (LET* (|a|) (DECLARE (SPECIAL |$stack|)) (COND - ((APPLY |f| NIL) (SETQ |a| |$stack|) (SETQ |$stack| NIL) - (LOOP (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) (T 0))) + ((APPLY |f| |ps| NIL) (SETQ |a| |$stack|) (SETQ |$stack| NIL) + (LOOP (COND ((NOT (APPLY |f| |ps| NIL)) (RETURN NIL)) (T NIL))) (SETQ |$stack| (CONS (|reverse!| |$stack|) |a|)) - (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) + (|bpPush| |ps| (CONS (|bpPop2|) (|bpPop1|)))) (T NIL)))) -(DEFUN |bpAnyNo| (|s|) - (PROGN (LOOP (COND ((NOT (APPLY |s| NIL)) (RETURN NIL)) (T 0))) T)) +(DEFUN |bpAnyNo| (|ps| |s|) + (PROGN (LOOP (COND ((NOT (APPLY |s| |ps| NIL)) (RETURN NIL)) (T NIL))) T)) -(DEFUN |bpAndOr| (|keyword| |p| |f|) - (AND (|bpEqKey| |keyword|) (|bpRequire| |p|) - (|bpPush| (FUNCALL |f| (|bpPop1|))))) +(DEFUN |bpAndOr| (|ps| |keyword| |p| |f|) + (AND (|bpEqKey| |keyword|) (|bpRequire| |ps| |p|) + (|bpPush| |ps| (FUNCALL |f| (|bpPop1|))))) -(DEFUN |bpConditional| (|f|) +(DEFUN |bpConditional| (|ps| |f|) (COND - ((AND (|bpEqKey| 'IF) (|bpRequire| #'|bpWhere|) (OR (|bpEqKey| 'BACKSET) T)) + ((AND (|bpEqKey| 'IF) (|bpRequire| |ps| #'|bpWhere|) + (OR (|bpEqKey| 'BACKSET) T)) (COND ((|bpEqKey| 'SETTAB) (COND ((|bpEqKey| 'THEN) - (AND (|bpRequire| |f|) (|bpElse| |f|) (|bpEqKey| 'BACKTAB))) + (AND (|bpRequire| |ps| |f|) (|bpElse| |ps| |f|) (|bpEqKey| 'BACKTAB))) (T (|bpMissing| 'THEN)))) - ((|bpEqKey| 'THEN) (AND (|bpRequire| |f|) (|bpElse| |f|))) + ((|bpEqKey| 'THEN) (AND (|bpRequire| |ps| |f|) (|bpElse| |ps| |f|))) (T (|bpMissing| '|then|)))) (T NIL))) -(DEFUN |bpElse| (|f|) +(DEFUN |bpElse| (|ps| |f|) (LET* (|a|) (PROGN (SETQ |a| (|bpState|)) (COND ((|bpBacksetElse|) - (AND (|bpRequire| |f|) - (|bpPush| (|bfIf| (|bpPop3|) (|bpPop2|) (|bpPop1|))))) + (AND (|bpRequire| |ps| |f|) + (|bpPush| |ps| (|bfIf| (|bpPop3|) (|bpPop2|) (|bpPop1|))))) (T (|bpRestore| |a|) - (|bpPush| (|bfIfThenOnly| (|bpPop2|) (|bpPop1|)))))))) + (|bpPush| |ps| (|bfIfThenOnly| (|bpPop2|) (|bpPop1|)))))))) (DEFUN |bpBacksetElse| () (COND ((|bpEqKey| 'BACKSET) (|bpEqKey| 'ELSE)) (T (|bpEqKey| 'ELSE)))) @@ -278,7 +332,7 @@ (THROW :OPEN-AXIOM-CATCH-POINT (CONS :OPEN-AXIOM-CATCH-POINT (CONS '(|BootParserException|) 'TRAPPED))))) -(DEFUN |bpRecoverTrap| () +(DEFUN |bpRecoverTrap| (|ps|) (LET* (|pos2| |pos1|) (DECLARE (SPECIAL |$stok|)) (PROGN @@ -287,9 +341,9 @@ (|bpMoveTo| 0) (SETQ |pos2| (|tokenPosition| |$stok|)) (|bpIgnoredFromTo| |pos1| |pos2|) - (|bpPush| (LIST (LIST "pile syntax error")))))) + (|bpPush| |ps| (LIST (LIST "pile syntax error")))))) -(DEFUN |bpListAndRecover| (|f|) +(DEFUN |bpListAndRecover| (|ps| |f|) (LET* (|found| |c| |done| |b| |a|) (DECLARE (SPECIAL |$inputStream| |$stack|)) (PROGN @@ -303,7 +357,8 @@ (T (SETQ |found| (LET ((#1=#:G719 - (CATCH :OPEN-AXIOM-CATCH-POINT (APPLY |f| NIL)))) + (CATCH :OPEN-AXIOM-CATCH-POINT + (APPLY |f| |ps| NIL)))) (COND ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT)) @@ -315,21 +370,21 @@ (T #1#)))) (COND ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|) - (|bpRecoverTrap|)) + (|bpRecoverTrap| |ps|)) ((NOT |found|) (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|) - (|bpRecoverTrap|))) + (|bpRecoverTrap| |ps|))) (COND ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|)) ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|)) (SETQ |done| T)) (T (SETQ |$inputStream| |c|) (|bpGeneralErrorHere|) - (|bpRecoverTrap|) + (|bpRecoverTrap| |ps|) (COND ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|)) (SETQ |done| T)) (T (|bpNext|) (SETQ |c| |$inputStream|))))) (SETQ |b| (CONS (|bpPop1|) |b|))))) (SETQ |$stack| |a|) - (|bpPush| (|reverse!| |b|))))) + (|bpPush| |ps| (|reverse!| |b|))))) (DEFUN |bpMoveTo| (|n|) (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$inputStream|)) @@ -347,136 +402,142 @@ (SETQ |$bpParenCount| (- |$bpParenCount| 1)) (|bpMoveTo| |n|)) (T (|bpNextToken|) (|bpMoveTo| |n|)))) -(DEFUN |bpQualifiedName| () +(DEFUN |bpQualifiedName| (|ps|) (DECLARE (SPECIAL |$stok|)) (COND ((|bpEqPeek| 'COLON-COLON) (|bpNext|) - (AND (EQ (|tokenClass| |$stok|) 'ID) (|bpPushId|) (|bpNext|) - (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|))))) + (AND (EQ (|tokenClass| |$stok|) 'ID) (|bpPushId| |ps|) (|bpNext|) + (|bpPush| |ps| (|bfColonColon| (|bpPop2|) (|bpPop1|))))) (T NIL))) -(DEFUN |bpName| () +(DEFUN |bpName| (|ps|) (DECLARE (SPECIAL |$stok|)) (COND - ((EQ (|tokenClass| |$stok|) 'ID) (|bpPushId|) (|bpNext|) - (|bpAnyNo| #'|bpQualifiedName|)) + ((EQ (|tokenClass| |$stok|) 'ID) (|bpPushId| |ps|) (|bpNext|) + (|bpAnyNo| |ps| #'|bpQualifiedName|)) (T NIL))) -(DEFUN |bpConstTok| () +(DEFUN |bpConstTok| (|ps|) (DECLARE (SPECIAL |$ttok| |$stok|)) (COND ((|symbolMember?| (|tokenClass| |$stok|) '(INTEGER FLOAT)) - (|bpPush| |$ttok|) (|bpNext|)) + (|bpPush| |ps| |$ttok|) (|bpNext|)) ((EQ (|tokenClass| |$stok|) 'LISP) - (AND (|bpPush| (|%Lisp| |$ttok|)) (|bpNext|))) - ((EQ (|tokenClass| |$stok|) 'LISPEXP) (AND (|bpPush| |$ttok|) (|bpNext|))) + (AND (|bpPush| |ps| (|%Lisp| |$ttok|)) (|bpNext|))) + ((EQ (|tokenClass| |$stok|) 'LISPEXP) + (AND (|bpPush| |ps| |$ttok|) (|bpNext|))) ((EQ (|tokenClass| |$stok|) 'LINE) - (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|))) + (AND (|bpPush| |ps| (LIST '+LINE |$ttok|)) (|bpNext|))) ((|bpEqPeek| 'QUOTE) (|bpNext|) - (AND (|bpRequire| #'|bpSexp|) (|bpPush| (|bfSymbol| (|bpPop1|))))) - (T (OR (|bpString|) (|bpFunction|))))) + (AND (|bpRequire| |ps| #'|bpSexp|) + (|bpPush| |ps| (|bfSymbol| (|bpPop1|))))) + (T (OR (|bpString| |ps|) (|bpFunction| |ps|))))) -(DEFUN |bpChar| () +(DEFUN |bpChar| (|ps|) (LET* (|ISTMP#1| |s| |a|) (DECLARE (SPECIAL |$ttok| |$stok|)) (COND ((AND (EQ (|tokenClass| |$stok|) 'ID) (EQ |$ttok| '|char|)) (SETQ |a| (|bpState|)) (COND - ((|bpApplication|) (SETQ |s| (|bpPop1|)) + ((|bpApplication| |ps|) (SETQ |s| (|bpPop1|)) (COND ((AND (CONSP |s|) (EQ (CAR |s|) '|char|) (PROGN (SETQ |ISTMP#1| (CDR |s|)) (AND (CONSP |ISTMP#1|) (NULL (CDR |ISTMP#1|))))) - (|bpPush| |s|)) + (|bpPush| |ps| |s|)) (T (|bpRestore| |a|) NIL))) (T NIL))) (T NIL)))) -(DEFUN |bpExportItemTail| () +(DEFUN |bpExportItemTail| (|ps|) (OR - (AND (|bpEqKey| 'BEC) (|bpRequire| #'|bpAssign|) - (|bpPush| (|%Assignment| (|bpPop2|) (|bpPop1|)))) - (|bpSimpleDefinitionTail|))) + (AND (|bpEqKey| 'BEC) (|bpRequire| |ps| #'|bpAssign|) + (|bpPush| |ps| (|%Assignment| (|bpPop2|) (|bpPop1|)))) + (|bpSimpleDefinitionTail| |ps|))) -(DEFUN |bpExportItem| () +(DEFUN |bpExportItem| (|ps|) (LET* (|a|) - (COND ((|bpEqPeek| 'STRUCTURE) (|bpStruct|)) + (COND ((|bpEqPeek| 'STRUCTURE) (|bpStruct| |ps|)) (T (SETQ |a| (|bpState|)) (COND - ((|bpName|) + ((|bpName| |ps|) (COND ((|bpEqPeek| 'COLON) (|bpRestore| |a|) - (|bpRequire| #'|bpSignature|) (OR (|bpExportItemTail|) T)) - (T (|bpRestore| |a|) (|bpTypeAliasDefition|)))) + (|bpRequire| |ps| #'|bpSignature|) + (OR (|bpExportItemTail| |ps|) T)) + (T (|bpRestore| |a|) (|bpTypeAliasDefition| |ps|)))) (T NIL)))))) -(DEFUN |bpExportItemList| () (|bpListAndRecover| #'|bpExportItem|)) +(DEFUN |bpExportItemList| (|ps|) (|bpListAndRecover| |ps| #'|bpExportItem|)) -(DEFUN |bpModuleInterface| () +(DEFUN |bpModuleInterface| (|ps|) (COND ((|bpEqKey| 'WHERE) - (OR (|bpPileBracketed| #'|bpExportItemList|) - (AND (|bpExportItem|) (|bpPush| (LIST (|bpPop1|)))) (|bpTrap|))) - (T (|bpPush| NIL)))) + (OR (|bpPileBracketed| |ps| #'|bpExportItemList|) + (AND (|bpExportItem| |ps|) (|bpPush| |ps| (LIST (|bpPop1|)))) + (|bpTrap|))) + (T (|bpPush| |ps| NIL)))) -(DEFUN |bpModuleExports| () - (COND ((|bpParenthesized| #'|bpIdList|) (|bpPush| (|bfUntuple| (|bpPop1|)))) - (T (|bpPush| NIL)))) +(DEFUN |bpModuleExports| (|ps|) + (COND + ((|bpParenthesized| |ps| #'|bpIdList|) + (|bpPush| |ps| (|bfUntuple| (|bpPop1|)))) + (T (|bpPush| |ps| NIL)))) -(DEFUN |bpModule| () +(DEFUN |bpModule| (|ps|) (COND - ((|bpEqKey| 'MODULE) (|bpRequire| #'|bpName|) (|bpModuleExports|) - (|bpModuleInterface|) - (|bpPush| (|%Module| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) + ((|bpEqKey| 'MODULE) (|bpRequire| |ps| #'|bpName|) (|bpModuleExports| |ps|) + (|bpModuleInterface| |ps|) + (|bpPush| |ps| (|%Module| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) (T NIL))) -(DEFUN |bpImport| () +(DEFUN |bpImport| (|ps|) (LET* (|a|) (COND ((|bpEqKey| 'IMPORT) (COND ((|bpEqKey| 'NAMESPACE) (OR - (AND (|bpLeftAssoc| '(DOT) #'|bpName|) - (|bpPush| (|%Import| (|bfNamespace| (|bpPop1|))))) + (AND (|bpLeftAssoc| |ps| '(DOT) #'|bpName|) + (|bpPush| |ps| (|%Import| (|bfNamespace| (|bpPop1|))))) (|bpTrap|))) - (T (SETQ |a| (|bpState|)) (|bpRequire| #'|bpName|) + (T (SETQ |a| (|bpState|)) (|bpRequire| |ps| #'|bpName|) (COND ((|bpEqPeek| 'COLON) (|bpRestore| |a|) - (AND (|bpRequire| #'|bpSignature|) (OR (|bpEqKey| 'FOR) (|bpTrap|)) - (|bpRequire| #'|bpName|) - (|bpPush| (|%ImportSignature| (|bpPop1|) (|bpPop1|))))) - (T (|bpPush| (|%Import| (|bpPop1|)))))))) + (AND (|bpRequire| |ps| #'|bpSignature|) + (OR (|bpEqKey| 'FOR) (|bpTrap|)) (|bpRequire| |ps| #'|bpName|) + (|bpPush| |ps| (|%ImportSignature| (|bpPop1|) (|bpPop1|))))) + (T (|bpPush| |ps| (|%Import| (|bpPop1|)))))))) (T NIL)))) -(DEFUN |bpNamespace| () - (AND (|bpEqKey| 'NAMESPACE) (OR (|bpName|) (|bpDot|)) - (|bpPush| (|bfNamespace| (|bpPop1|))))) +(DEFUN |bpNamespace| (|ps|) + (AND (|bpEqKey| 'NAMESPACE) (OR (|bpName| |ps|) (|bpDot| |ps|)) + (|bpPush| |ps| (|bfNamespace| (|bpPop1|))))) -(DEFUN |bpTypeAliasDefition| () - (AND (OR (|bpTerm| #'|bpIdList|) (|bpTrap|)) (|bpEqKey| 'TDEF) (|bpLogical|) - (|bpPush| (|%TypeAlias| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpTypeAliasDefition| (|ps|) + (AND (OR (|bpTerm| |ps| #'|bpIdList|) (|bpTrap|)) (|bpEqKey| 'TDEF) + (|bpLogical| |ps|) (|bpPush| |ps| (|%TypeAlias| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpSignature| () - (AND (|bpName|) (|bpEqKey| 'COLON) (|bpRequire| #'|bpTyping|) - (|bpPush| (|%Signature| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpSignature| (|ps|) + (AND (|bpName| |ps|) (|bpEqKey| 'COLON) (|bpRequire| |ps| #'|bpTyping|) + (|bpPush| |ps| (|%Signature| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpSimpleMapping| () +(DEFUN |bpSimpleMapping| (|ps|) (COND - ((|bpApplication|) - (AND (|bpEqKey| 'ARROW) (|bpRequire| #'|bpApplication|) - (|bpPush| (|%Mapping| (|bpPop1|) (LIST (|bpPop1|))))) + ((|bpApplication| |ps|) + (AND (|bpEqKey| 'ARROW) (|bpRequire| |ps| #'|bpApplication|) + (|bpPush| |ps| (|%Mapping| (|bpPop1|) (LIST (|bpPop1|))))) T) (T NIL))) -(DEFUN |bpArgtypeList| () (|bpTuple| #'|bpSimpleMapping|)) +(DEFUN |bpArgtypeList| (|ps|) (|bpTuple| |ps| #'|bpSimpleMapping|)) -(DEFUN |bpMapping| () - (AND (|bpParenthesized| #'|bpArgtypeList|) (|bpEqKey| 'ARROW) - (|bpApplication|) - (|bpPush| (|%Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|)))))) +(DEFUN |bpMapping| (|ps|) + (AND (|bpParenthesized| |ps| #'|bpArgtypeList|) (|bpEqKey| 'ARROW) + (|bpApplication| |ps|) + (|bpPush| |ps| (|%Mapping| (|bpPop1|) (|bfUntuple| (|bpPop1|)))))) (DEFUN |bpCancel| () (LET* (|a|) @@ -505,243 +566,258 @@ (|bpEqPeek| 'CPAREN) (|bpEqPeek| 'SETTAB) (|bpEqPeek| 'BACKTAB) (|bpEqPeek| 'BACKSET))) -(DEFUN |bpSexpKey| () +(DEFUN |bpSexpKey| (|ps|) (LET* (|a|) (DECLARE (SPECIAL |$ttok| |$stok|)) (COND ((AND (EQ (|tokenClass| |$stok|) 'KEY) (NOT (|bpExceptions|))) (SETQ |a| (GET |$ttok| 'SHOEINF)) - (COND ((NULL |a|) (AND (|bpPush| (|keywordId| |$ttok|)) (|bpNext|))) - (T (AND (|bpPush| |a|) (|bpNext|))))) + (COND ((NULL |a|) (AND (|bpPush| |ps| (|keywordId| |$ttok|)) (|bpNext|))) + (T (AND (|bpPush| |ps| |a|) (|bpNext|))))) (T NIL)))) -(DEFUN |bpAnyId| () +(DEFUN |bpAnyId| (|ps|) (DECLARE (SPECIAL |$ttok| |$stok|)) (OR (AND (|bpEqKey| 'MINUS) (OR (EQ (|tokenClass| |$stok|) 'INTEGER) (|bpTrap|)) - (|bpPush| (- |$ttok|)) (|bpNext|)) - (|bpSexpKey|) + (|bpPush| |ps| (- |$ttok|)) (|bpNext|)) + (|bpSexpKey| |ps|) (AND (|symbolMember?| (|tokenClass| |$stok|) '(ID INTEGER STRING FLOAT)) - (|bpPush| |$ttok|) (|bpNext|)))) + (|bpPush| |ps| |$ttok|) (|bpNext|)))) -(DEFUN |bpSexp| () - (OR (|bpAnyId|) - (AND (|bpEqKey| 'QUOTE) (|bpRequire| #'|bpSexp|) - (|bpPush| (|bfSymbol| (|bpPop1|)))) - (|bpIndentParenthesized| #'|bpSexp1|))) +(DEFUN |bpSexp| (|ps|) + (OR (|bpAnyId| |ps|) + (AND (|bpEqKey| 'QUOTE) (|bpRequire| |ps| #'|bpSexp|) + (|bpPush| |ps| (|bfSymbol| (|bpPop1|)))) + (|bpIndentParenthesized| |ps| #'|bpSexp1|))) -(DEFUN |bpSexp1| () +(DEFUN |bpSexp1| (|ps|) (OR - (AND (|bpFirstTok|) (|bpSexp|) + (AND (|bpFirstTok|) (|bpSexp| |ps|) (OR - (AND (|bpEqKey| 'DOT) (|bpSexp|) - (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) - (AND (|bpSexp1|) (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))))) - (|bpPush| NIL))) + (AND (|bpEqKey| 'DOT) (|bpSexp| |ps|) + (|bpPush| |ps| (CONS (|bpPop2|) (|bpPop1|)))) + (AND (|bpSexp1| |ps|) (|bpPush| |ps| (CONS (|bpPop2|) (|bpPop1|)))))) + (|bpPush| |ps| NIL))) -(DEFUN |bpPrimary1| () - (OR (|bpParenthesizedApplication|) (|bpDot|) (|bpConstTok|) (|bpConstruct|) - (|bpCase|) (|bpStruct|) (|bpPDefinition|) (|bpBPileDefinition|))) +(DEFUN |bpPrimary1| (|ps|) + (OR (|bpParenthesizedApplication| |ps|) (|bpDot| |ps|) (|bpConstTok| |ps|) + (|bpConstruct| |ps|) (|bpCase| |ps|) (|bpStruct| |ps|) + (|bpPDefinition| |ps|) (|bpBPileDefinition| |ps|))) -(DEFUN |bpParenthesizedApplication| () - (AND (|bpName|) (|bpAnyNo| #'|bpArgumentList|))) +(DEFUN |bpParenthesizedApplication| (|ps|) + (AND (|bpName| |ps|) (|bpAnyNo| |ps| #'|bpArgumentList|))) -(DEFUN |bpArgumentList| () - (AND (|bpPDefinition|) (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpArgumentList| (|ps|) + (AND (|bpPDefinition| |ps|) + (|bpPush| |ps| (|bfApplication| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpPrimary| () - (AND (|bpFirstTok|) (OR (|bpPrimary1|) (|bpPrefixOperator|)))) +(DEFUN |bpPrimary| (|ps|) + (AND (|bpFirstTok|) (OR (|bpPrimary1| |ps|) (|bpPrefixOperator| |ps|)))) -(DEFUN |bpDot| () (AND (|bpEqKey| 'DOT) (|bpPush| (|bfDot|)))) +(DEFUN |bpDot| (|ps|) (AND (|bpEqKey| 'DOT) (|bpPush| |ps| (|bfDot|)))) -(DEFUN |bpPrefixOperator| () +(DEFUN |bpPrefixOperator| (|ps|) (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|tokenClass| |$stok|) 'KEY) (GET |$ttok| 'SHOEPRE) (|bpPushId|) - (|bpNext|))) + (AND (EQ (|tokenClass| |$stok|) 'KEY) (GET |$ttok| 'SHOEPRE) + (|bpPushId| |ps|) (|bpNext|))) -(DEFUN |bpInfixOperator| () +(DEFUN |bpInfixOperator| (|ps|) (DECLARE (SPECIAL |$ttok| |$stok|)) - (AND (EQ (|tokenClass| |$stok|) 'KEY) (GET |$ttok| 'SHOEINF) (|bpPushId|) - (|bpNext|))) + (AND (EQ (|tokenClass| |$stok|) 'KEY) (GET |$ttok| 'SHOEINF) + (|bpPushId| |ps|) (|bpNext|))) -(DEFUN |bpSelector| () +(DEFUN |bpSelector| (|ps|) (AND (|bpEqKey| 'DOT) - (OR (AND (|bpPrimary|) (|bpPush| (|bfElt| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfSuffixDot| (|bpPop1|)))))) + (OR + (AND (|bpPrimary| |ps|) + (|bpPush| |ps| (|bfElt| (|bpPop2|) (|bpPop1|)))) + (|bpPush| |ps| (|bfSuffixDot| (|bpPop1|)))))) -(DEFUN |bpApplication| () +(DEFUN |bpApplication| (|ps|) (OR - (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|) + (AND (|bpPrimary| |ps|) (|bpAnyNo| |ps| #'|bpSelector|) (OR - (AND (|bpApplication|) - (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) + (AND (|bpApplication| |ps|) + (|bpPush| |ps| (|bfApplication| (|bpPop2|) (|bpPop1|)))) T)) - (|bpNamespace|))) + (|bpNamespace| |ps|))) -(DEFUN |bpTyping| () +(DEFUN |bpTyping| (|ps|) (COND - ((|bpEqKey| 'FORALL) (|bpRequire| #'|bpVariable|) - (OR (AND (|bpDot|) (|bpPop1|)) (|bpTrap|)) (|bpRequire| #'|bpTyping|) - (|bpPush| (|%Forall| (|bpPop2|) (|bpPop1|)))) - (T (OR (|bpMapping|) (|bpSimpleMapping|))))) - -(DEFUN |bpTyped| () - (AND (|bpApplication|) + ((|bpEqKey| 'FORALL) (|bpRequire| |ps| #'|bpVariable|) + (OR (AND (|bpDot| |ps|) (|bpPop1|)) (|bpTrap|)) + (|bpRequire| |ps| #'|bpTyping|) + (|bpPush| |ps| (|%Forall| (|bpPop2|) (|bpPop1|)))) + (T (OR (|bpMapping| |ps|) (|bpSimpleMapping| |ps|))))) + +(DEFUN |bpTyped| (|ps|) + (AND (|bpApplication| |ps|) (COND ((|bpEqKey| 'COLON) - (AND (|bpRequire| #'|bpTyping|) - (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|))))) + (AND (|bpRequire| |ps| #'|bpTyping|) + (|bpPush| |ps| (|bfTagged| (|bpPop2|) (|bpPop1|))))) ((|bpEqKey| 'AT) - (AND (|bpRequire| #'|bpTyping|) - (|bpPush| (|bfRestrict| (|bpPop2|) (|bpPop1|))))) + (AND (|bpRequire| |ps| #'|bpTyping|) + (|bpPush| |ps| (|bfRestrict| (|bpPop2|) (|bpPop1|))))) (T T)))) -(DEFUN |bpExpt| () (|bpRightAssoc| '(POWER) #'|bpTyped|)) +(DEFUN |bpExpt| (|ps|) (|bpRightAssoc| |ps| '(POWER) #'|bpTyped|)) -(DEFUN |bpInfKey| (|s|) +(DEFUN |bpInfKey| (|ps| |s|) (DECLARE (SPECIAL |$ttok| |$stok|)) (AND (EQ (|tokenClass| |$stok|) 'KEY) (|symbolMember?| |$ttok| |s|) - (|bpPushId|) (|bpNext|))) + (|bpPushId| |ps|) (|bpNext|))) -(DEFUN |bpInfGeneric| (|s|) (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T))) +(DEFUN |bpInfGeneric| (|ps| |s|) + (AND (|bpInfKey| |ps| |s|) (OR (|bpEqKey| 'BACKSET) T))) -(DEFUN |bpRightAssoc| (|o| |p|) +(DEFUN |bpRightAssoc| (|ps| |o| |p|) (LET* (|a|) (PROGN (SETQ |a| (|bpState|)) (COND - ((APPLY |p| NIL) + ((APPLY |p| |ps| NIL) (LOOP (COND ((NOT - (AND (|bpInfGeneric| |o|) (OR (|bpRightAssoc| |o| |p|) (|bpTrap|)))) + (AND (|bpInfGeneric| |ps| |o|) + (OR (|bpRightAssoc| |ps| |o| |p|) (|bpTrap|)))) (RETURN NIL)) - (T (|bpPush| (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))))) + (T + (|bpPush| |ps| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))))) T) (T (|bpRestore| |a|) NIL))))) -(DEFUN |bpLeftAssoc| (|operations| |parser|) +(DEFUN |bpLeftAssoc| (|ps| |operations| |parser|) (COND - ((APPLY |parser| NIL) + ((APPLY |parser| |ps| NIL) (LOOP (COND - ((NOT (AND (|bpInfGeneric| |operations|) (|bpRequire| |parser|))) + ((NOT + (AND (|bpInfGeneric| |ps| |operations|) (|bpRequire| |ps| |parser|))) (RETURN NIL)) - (T (|bpPush| (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))))) + (T + (|bpPush| |ps| (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))))) T) (T NIL))) -(DEFUN |bpString| () +(DEFUN |bpString| (|ps|) (DECLARE (SPECIAL |$ttok| |$stok|)) (AND (EQ (|tokenClass| |$stok|) 'STRING) - (|bpPush| (|quote| (INTERN |$ttok|))) (|bpNext|))) + (|bpPush| |ps| (|quote| (INTERN |$ttok|))) (|bpNext|))) -(DEFUN |bpFunction| () - (AND (|bpEqKey| 'FUNCTION) (|bpRequire| #'|bpPrimary1|) - (|bpPush| (|bfFunction| (|bpPop1|))))) +(DEFUN |bpFunction| (|ps|) + (AND (|bpEqKey| 'FUNCTION) (|bpRequire| |ps| #'|bpPrimary1|) + (|bpPush| |ps| (|bfFunction| (|bpPop1|))))) -(DEFUN |bpThetaName| () +(DEFUN |bpThetaName| (|ps|) (DECLARE (SPECIAL |$ttok| |$stok|)) (COND - ((AND (EQ (|tokenClass| |$stok|) 'ID) (GET |$ttok| 'SHOETHETA)) (|bpPushId|) - (|bpNext|)) + ((AND (EQ (|tokenClass| |$stok|) 'ID) (GET |$ttok| 'SHOETHETA)) + (|bpPushId| |ps|) (|bpNext|)) (T NIL))) -(DEFUN |bpReduceOperator| () - (OR (|bpInfixOperator|) (|bpString|) (|bpThetaName|))) +(DEFUN |bpReduceOperator| (|ps|) + (OR (|bpInfixOperator| |ps|) (|bpString| |ps|) (|bpThetaName| |ps|))) -(DEFUN |bpReduce| () +(DEFUN |bpReduce| (|ps|) (LET* (|a|) (PROGN (SETQ |a| (|bpState|)) (COND - ((AND (|bpReduceOperator|) (|bpEqKey| 'SLASH)) + ((AND (|bpReduceOperator| |ps|) (|bpEqKey| 'SLASH)) (COND ((|bpEqPeek| 'OBRACK) - (AND (|bpRequire| #'|bpDConstruct|) - (|bpPush| (|bfReduceCollect| (|bpPop2|) (|bpPop1|))))) + (AND (|bpRequire| |ps| #'|bpDConstruct|) + (|bpPush| |ps| (|bfReduceCollect| (|bpPop2|) (|bpPop1|))))) (T - (AND (|bpRequire| #'|bpApplication|) - (|bpPush| (|bfReduce| (|bpPop2|) (|bpPop1|))))))) + (AND (|bpRequire| |ps| #'|bpApplication|) + (|bpPush| |ps| (|bfReduce| (|bpPop2|) (|bpPop1|))))))) (T (|bpRestore| |a|) NIL))))) -(DEFUN |bpTimes| () (OR (|bpReduce|) (|bpLeftAssoc| '(TIMES SLASH) #'|bpExpt|))) +(DEFUN |bpTimes| (|ps|) + (OR (|bpReduce| |ps|) (|bpLeftAssoc| |ps| '(TIMES SLASH) #'|bpExpt|))) -(DEFUN |bpEuclid| () (|bpLeftAssoc| '(QUO REM) #'|bpTimes|)) +(DEFUN |bpEuclid| (|ps|) (|bpLeftAssoc| |ps| '(QUO REM) #'|bpTimes|)) -(DEFUN |bpMinus| () +(DEFUN |bpMinus| (|ps|) (OR - (AND (|bpInfGeneric| '(MINUS)) (|bpRequire| #'|bpEuclid|) - (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) - (|bpEuclid|))) + (AND (|bpInfGeneric| |ps| '(MINUS)) (|bpRequire| |ps| #'|bpEuclid|) + (|bpPush| |ps| (|bfApplication| (|bpPop2|) (|bpPop1|)))) + (|bpEuclid| |ps|))) -(DEFUN |bpArith| () (|bpLeftAssoc| '(PLUS MINUS) #'|bpMinus|)) +(DEFUN |bpArith| (|ps|) (|bpLeftAssoc| |ps| '(PLUS MINUS) #'|bpMinus|)) -(DEFUN |bpIs| () - (AND (|bpArith|) +(DEFUN |bpIs| (|ps|) + (AND (|bpArith| |ps|) (COND - ((AND (|bpInfKey| '(IS ISNT)) (|bpRequire| #'|bpPattern|)) - (|bpPush| (|bfISApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))) - ((AND (|bpEqKey| 'HAS) (|bpRequire| #'|bpApplication|)) - (|bpPush| (|bfHas| (|bpPop2|) (|bpPop1|)))) + ((AND (|bpInfKey| |ps| '(IS ISNT)) (|bpRequire| |ps| #'|bpPattern|)) + (|bpPush| |ps| (|bfISApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))) + ((AND (|bpEqKey| 'HAS) (|bpRequire| |ps| #'|bpApplication|)) + (|bpPush| |ps| (|bfHas| (|bpPop2|) (|bpPop1|)))) (T T)))) -(DEFUN |bpBracketConstruct| (|f|) - (AND (|bpBracket| |f|) (|bpPush| (|bfConstruct| (|bpPop1|))))) +(DEFUN |bpBracketConstruct| (|ps| |f|) + (AND (|bpBracket| |ps| |f|) (|bpPush| |ps| (|bfConstruct| (|bpPop1|))))) -(DEFUN |bpCompare| () +(DEFUN |bpCompare| (|ps|) (OR - (AND (|bpIs|) + (AND (|bpIs| |ps|) (OR - (AND (|bpInfKey| '(SHOEEQ SHOENE LT LE GT GE IN)) - (|bpRequire| #'|bpIs|) - (|bpPush| (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))) + (AND (|bpInfKey| |ps| '(SHOEEQ SHOENE LT LE GT GE IN)) + (|bpRequire| |ps| #'|bpIs|) + (|bpPush| |ps| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) (|bpPop1|)))) T)) - (|bpLeave|) (|bpThrow|))) + (|bpLeave| |ps|) (|bpThrow| |ps|))) -(DEFUN |bpAnd| () (|bpLeftAssoc| '(AND) #'|bpCompare|)) +(DEFUN |bpAnd| (|ps|) (|bpLeftAssoc| |ps| '(AND) #'|bpCompare|)) -(DEFUN |bpThrow| () +(DEFUN |bpThrow| (|ps|) (COND - ((AND (|bpEqKey| 'THROW) (|bpApplication|)) + ((AND (|bpEqKey| 'THROW) (|bpApplication| |ps|)) (COND - ((|bpEqKey| 'COLON) (|bpRequire| #'|bpApplication|) - (|bpPush| (|%Pretend| (|bpPop2|) (|bpPop1|))))) - (|bpPush| (|bfThrow| (|bpPop1|)))) + ((|bpEqKey| 'COLON) (|bpRequire| |ps| #'|bpApplication|) + (|bpPush| |ps| (|%Pretend| (|bpPop2|) (|bpPop1|))))) + (|bpPush| |ps| (|bfThrow| (|bpPop1|)))) (T NIL))) -(DEFUN |bpTry| () +(DEFUN |bpTry| (|ps|) (LET* (|cs|) (COND - ((|bpEqKey| 'TRY) (|bpAssign|) (SETQ |cs| NIL) + ((|bpEqKey| 'TRY) (|bpAssign| |ps|) (SETQ |cs| NIL) (LOOP (COND ((NOT (|bpHandler| 'CATCH)) (RETURN NIL)) - (T (|bpCatchItem|) (SETQ |cs| (CONS (|bpPop1|) |cs|))))) + (T (|bpCatchItem| |ps|) (SETQ |cs| (CONS (|bpPop1|) |cs|))))) (COND ((|bpHandler| 'FINALLY) - (AND (|bpFinally|) - (|bpPush| - (|bfTry| (|bpPop2|) (|reverse!| (CONS (|bpPop1|) |cs|)))))) + (AND (|bpFinally| |ps|) + (|bpPush| |ps| + (|bfTry| (|bpPop2|) + (|reverse!| (CONS (|bpPop1|) |cs|)))))) ((NULL |cs|) (|bpTrap|)) - (T (|bpPush| (|bfTry| (|bpPop1|) (|reverse!| |cs|)))))) + (T (|bpPush| |ps| (|bfTry| (|bpPop1|) (|reverse!| |cs|)))))) (T NIL)))) -(DEFUN |bpCatchItem| () - (AND (|bpRequire| #'|bpExceptionVariable|) (OR (|bpEqKey| 'EXIT) (|bpTrap|)) - (|bpRequire| #'|bpAssign|) (|bpPush| (|%Catch| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpCatchItem| (|ps|) + (AND (|bpRequire| |ps| #'|bpExceptionVariable|) + (OR (|bpEqKey| 'EXIT) (|bpTrap|)) (|bpRequire| |ps| #'|bpAssign|) + (|bpPush| |ps| (|%Catch| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpExceptionVariable| () +(DEFUN |bpExceptionVariable| (|ps|) (LET* (|t|) (DECLARE (SPECIAL |$stok|)) (PROGN (SETQ |t| |$stok|) (OR - (AND (|bpEqKey| 'OPAREN) (|bpRequire| #'|bpSignature|) + (AND (|bpEqKey| 'OPAREN) (|bpRequire| |ps| #'|bpSignature|) (OR (|bpEqKey| 'CPAREN) (|bpMissing| |t|))) (|bpTrap|))))) -(DEFUN |bpFinally| () - (AND (|bpRequire| #'|bpAssign|) (|bpPush| (|%Finally| (|bpPop1|))))) +(DEFUN |bpFinally| (|ps|) + (AND (|bpRequire| |ps| #'|bpAssign|) (|bpPush| |ps| (|%Finally| (|bpPop1|))))) (DEFUN |bpHandler| (|key|) (LET* (|s|) @@ -752,121 +828,136 @@ T) (T (|bpRestore| |s|) NIL))))) -(DEFUN |bpLeave| () - (AND (|bpEqKey| 'LEAVE) (|bpRequire| #'|bpLogical|) - (|bpPush| (|bfLeave| (|bpPop1|))))) +(DEFUN |bpLeave| (|ps|) + (AND (|bpEqKey| 'LEAVE) (|bpRequire| |ps| #'|bpLogical|) + (|bpPush| |ps| (|bfLeave| (|bpPop1|))))) -(DEFUN |bpDo| () +(DEFUN |bpDo| (|ps|) (COND - ((|bpEqKey| 'IN) (|bpRequire| #'|bpNamespace|) (|bpRequire| #'|bpDo|) - (|bpPush| (|bfAtScope| (|bpPop2|) (|bpPop1|)))) + ((|bpEqKey| 'IN) (|bpRequire| |ps| #'|bpNamespace|) + (|bpRequire| |ps| #'|bpDo|) + (|bpPush| |ps| (|bfAtScope| (|bpPop2|) (|bpPop1|)))) (T - (AND (|bpEqKey| 'DO) (|bpRequire| #'|bpAssign|) - (|bpPush| (|bfDo| (|bpPop1|))))))) + (AND (|bpEqKey| 'DO) (|bpRequire| |ps| #'|bpAssign|) + (|bpPush| |ps| (|bfDo| (|bpPop1|))))))) -(DEFUN |bpReturn| () +(DEFUN |bpReturn| (|ps|) (OR - (AND (|bpEqKey| 'RETURN) (|bpRequire| #'|bpAssign|) - (|bpPush| (|bfReturnNoName| (|bpPop1|)))) - (|bpLeave|) (|bpThrow|) (|bpAnd|) (|bpDo|))) + (AND (|bpEqKey| 'RETURN) (|bpRequire| |ps| #'|bpAssign|) + (|bpPush| |ps| (|bfReturnNoName| (|bpPop1|)))) + (|bpLeave| |ps|) (|bpThrow| |ps|) (|bpAnd| |ps|) (|bpDo| |ps|))) -(DEFUN |bpLogical| () (|bpLeftAssoc| '(OR) #'|bpReturn|)) +(DEFUN |bpLogical| (|ps|) (|bpLeftAssoc| |ps| '(OR) #'|bpReturn|)) -(DEFUN |bpExpression| () +(DEFUN |bpExpression| (|ps|) (OR (AND (|bpEqKey| 'COLON) - (OR (AND (|bpLogical|) (|bpPush| (|bfApplication| 'COLON (|bpPop1|)))) - (|bpTrap|))) - (|bpLogical|))) + (OR + (AND (|bpLogical| |ps|) + (|bpPush| |ps| (|bfApplication| 'COLON (|bpPop1|)))) + (|bpTrap|))) + (|bpLogical| |ps|))) -(DEFUN |bpStatement| () - (OR (|bpConditional| #'|bpWhere|) (|bpLoop|) (|bpExpression|) (|bpTry|))) +(DEFUN |bpStatement| (|ps|) + (OR (|bpConditional| |ps| #'|bpWhere|) (|bpLoop| |ps|) (|bpExpression| |ps|) + (|bpTry| |ps|))) -(DEFUN |bpLoop| () +(DEFUN |bpLoop| (|ps|) (OR - (AND (|bpIterators|) (|bpCompMissing| 'REPEAT) (|bpRequire| #'|bpWhere|) - (|bpPush| (|bfLp| (|bpPop2|) (|bpPop1|)))) - (AND (|bpEqKey| 'REPEAT) (|bpRequire| #'|bpLogical|) - (|bpPush| (|bfLoop1| (|bpPop1|)))))) + (AND (|bpIterators| |ps|) (|bpCompMissing| 'REPEAT) + (|bpRequire| |ps| #'|bpWhere|) + (|bpPush| |ps| (|bfLp| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'REPEAT) (|bpRequire| |ps| #'|bpLogical|) + (|bpPush| |ps| (|bfLoop1| (|bpPop1|)))))) -(DEFUN |bpSuchThat| () (|bpAndOr| 'BAR #'|bpWhere| #'|bfSuchthat|)) +(DEFUN |bpSuchThat| (|ps|) (|bpAndOr| |ps| 'BAR #'|bpWhere| #'|bfSuchthat|)) -(DEFUN |bpWhile| () (|bpAndOr| 'WHILE #'|bpLogical| #'|bfWhile|)) +(DEFUN |bpWhile| (|ps|) (|bpAndOr| |ps| 'WHILE #'|bpLogical| #'|bfWhile|)) -(DEFUN |bpUntil| () (|bpAndOr| 'UNTIL #'|bpLogical| #'|bfUntil|)) +(DEFUN |bpUntil| (|ps|) (|bpAndOr| |ps| 'UNTIL #'|bpLogical| #'|bfUntil|)) -(DEFUN |bpFormal| () (OR (|bpVariable|) (|bpDot|))) +(DEFUN |bpFormal| (|ps|) (OR (|bpVariable| |ps|) (|bpDot| |ps|))) -(DEFUN |bpForIn| () - (AND (|bpEqKey| 'FOR) (|bpRequire| #'|bpFormal|) (|bpCompMissing| 'IN) +(DEFUN |bpForIn| (|ps|) + (AND (|bpEqKey| 'FOR) (|bpRequire| |ps| #'|bpFormal|) (|bpCompMissing| 'IN) (OR - (AND (|bpRequire| #'|bpSeg|) (|bpEqKey| 'BY) (|bpRequire| #'|bpArith|) - (|bpPush| (|bfForInBy| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfForin| (|bpPop2|) (|bpPop1|)))))) + (AND (|bpRequire| |ps| #'|bpSeg|) (|bpEqKey| 'BY) + (|bpRequire| |ps| #'|bpArith|) + (|bpPush| |ps| (|bfForInBy| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) + (|bpPush| |ps| (|bfForin| (|bpPop2|) (|bpPop1|)))))) -(DEFUN |bpSeg| () - (AND (|bpArith|) +(DEFUN |bpSeg| (|ps|) + (AND (|bpArith| |ps|) (OR (AND (|bpEqKey| 'SEG) (OR - (AND (|bpArith|) (|bpPush| (|bfSegment2| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfSegment1| (|bpPop1|))))) + (AND (|bpArith| |ps|) + (|bpPush| |ps| (|bfSegment2| (|bpPop2|) (|bpPop1|)))) + (|bpPush| |ps| (|bfSegment1| (|bpPop1|))))) T))) -(DEFUN |bpIterator| () (OR (|bpForIn|) (|bpSuchThat|) (|bpWhile|) (|bpUntil|))) +(DEFUN |bpIterator| (|ps|) + (OR (|bpForIn| |ps|) (|bpSuchThat| |ps|) (|bpWhile| |ps|) (|bpUntil| |ps|))) -(DEFUN |bpIteratorList| () - (AND (|bpOneOrMore| #'|bpIterator|) (|bpPush| (|bfIterators| (|bpPop1|))))) +(DEFUN |bpIteratorList| (|ps|) + (AND (|bpOneOrMore| |ps| #'|bpIterator|) + (|bpPush| |ps| (|bfIterators| (|bpPop1|))))) -(DEFUN |bpCrossBackSet| () (AND (|bpEqKey| 'CROSS) (OR (|bpEqKey| 'BACKSET) T))) +(DEFUN |bpCrossBackSet| (|ps|) + (AND (|bpEqKey| 'CROSS) (OR (|bpEqKey| 'BACKSET) T))) -(DEFUN |bpIterators| () - (|bpListofFun| #'|bpIteratorList| #'|bpCrossBackSet| #'|bfCross|)) +(DEFUN |bpIterators| (|ps|) + (|bpListofFun| |ps| #'|bpIteratorList| #'|bpCrossBackSet| #'|bfCross|)) -(DEFUN |bpAssign| () +(DEFUN |bpAssign| (|ps|) (LET* (|a|) (PROGN (SETQ |a| (|bpState|)) (COND - ((|bpStatement|) + ((|bpStatement| |ps|) (COND - ((|bpEqPeek| 'BEC) (|bpRestore| |a|) (|bpRequire| #'|bpAssignment|)) - ((|bpEqPeek| 'GIVES) (|bpRestore| |a|) (|bpRequire| #'|bpLambda|)) - ((|bpEqPeek| 'LARROW) (|bpRestore| |a|) (|bpRequire| #'|bpKeyArg|)) + ((|bpEqPeek| 'BEC) (|bpRestore| |a|) + (|bpRequire| |ps| #'|bpAssignment|)) + ((|bpEqPeek| 'GIVES) (|bpRestore| |a|) (|bpRequire| |ps| #'|bpLambda|)) + ((|bpEqPeek| 'LARROW) (|bpRestore| |a|) + (|bpRequire| |ps| #'|bpKeyArg|)) (T T))) (T (|bpRestore| |a|) NIL))))) -(DEFUN |bpAssignment| () - (AND (|bpAssignVariable|) (|bpEqKey| 'BEC) (|bpRequire| #'|bpAssign|) - (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpAssignment| (|ps|) + (AND (|bpAssignVariable| |ps|) (|bpEqKey| 'BEC) + (|bpRequire| |ps| #'|bpAssign|) + (|bpPush| |ps| (|bfAssign| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpLambda| () - (AND (|bpVariable|) (|bpEqKey| 'GIVES) (|bpRequire| #'|bpAssign|) - (|bpPush| (|bfLambda| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpLambda| (|ps|) + (AND (|bpVariable| |ps|) (|bpEqKey| 'GIVES) (|bpRequire| |ps| #'|bpAssign|) + (|bpPush| |ps| (|bfLambda| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpKeyArg| () - (AND (|bpName|) (|bpEqKey| 'LARROW) (|bpLogical|) - (|bpPush| (|bfKeyArg| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpKeyArg| (|ps|) + (AND (|bpName| |ps|) (|bpEqKey| 'LARROW) (|bpLogical| |ps|) + (|bpPush| |ps| (|bfKeyArg| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpExit| () - (AND (|bpAssign|) +(DEFUN |bpExit| (|ps|) + (AND (|bpAssign| |ps|) (OR - (AND (|bpEqKey| 'EXIT) (|bpRequire| #'|bpWhere|) - (|bpPush| (|bfExit| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'EXIT) (|bpRequire| |ps| #'|bpWhere|) + (|bpPush| |ps| (|bfExit| (|bpPop2|) (|bpPop1|)))) T))) -(DEFUN |bpDefinition| () +(DEFUN |bpDefinition| (|ps|) (LET* (|a|) (COND ((|bpEqKey| 'MACRO) (OR - (AND (|bpName|) (|bpStoreName|) (|bpCompoundDefinitionTail| #'|%Macro|)) + (AND (|bpName| |ps|) (|bpStoreName|) + (|bpCompoundDefinitionTail| |ps| #'|%Macro|)) (|bpTrap|))) (T (SETQ |a| (|bpState|)) (COND - ((|bpExit|) - (COND ((|bpEqPeek| 'DEF) (|bpRestore| |a|) (|bpDef|)) - ((|bpEqPeek| 'TDEF) (|bpRestore| |a|) (|bpTypeAliasDefition|)) + ((|bpExit| |ps|) + (COND ((|bpEqPeek| 'DEF) (|bpRestore| |a|) (|bpDef| |ps|)) + ((|bpEqPeek| 'TDEF) (|bpRestore| |a|) + (|bpTypeAliasDefition| |ps|)) (T T))) (T (|bpRestore| |a|) NIL)))))) @@ -878,320 +969,336 @@ (SETQ |$typings| NIL) T)) -(DEFUN |bpDef| () - (OR (AND (|bpName|) (|bpStoreName|) (|bpDefTail| #'|%Definition|)) - (AND (|bpNamespace|) (|bpSimpleDefinitionTail|)))) +(DEFUN |bpDef| (|ps|) + (OR (AND (|bpName| |ps|) (|bpStoreName|) (|bpDefTail| |ps| #'|%Definition|)) + (AND (|bpNamespace| |ps|) (|bpSimpleDefinitionTail| |ps|)))) -(DEFUN |bpDDef| () (AND (|bpName|) (|bpDefTail| #'|%Definition|))) +(DEFUN |bpDDef| (|ps|) (AND (|bpName| |ps|) (|bpDefTail| |ps| #'|%Definition|))) -(DEFUN |bpSimpleDefinitionTail| () - (AND (|bpEqKey| 'DEF) (|bpRequire| #'|bpWhere|) - (|bpPush| (|%ConstantDefinition| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpSimpleDefinitionTail| (|ps|) + (AND (|bpEqKey| 'DEF) (|bpRequire| |ps| #'|bpWhere|) + (|bpPush| |ps| (|%ConstantDefinition| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpCompoundDefinitionTail| (|f|) - (AND (|bpVariable|) (|bpEqKey| 'DEF) (|bpRequire| #'|bpWhere|) - (|bpPush| (APPLY |f| (LIST (|bpPop3|) (|bpPop2|) (|bpPop1|)))))) +(DEFUN |bpCompoundDefinitionTail| (|ps| |f|) + (AND (|bpVariable| |ps|) (|bpEqKey| 'DEF) (|bpRequire| |ps| #'|bpWhere|) + (|bpPush| |ps| (APPLY |f| (LIST (|bpPop3|) (|bpPop2|) (|bpPop1|)))))) -(DEFUN |bpDefTail| (|f|) - (OR (|bpSimpleDefinitionTail|) (|bpCompoundDefinitionTail| |f|))) +(DEFUN |bpDefTail| (|ps| |f|) + (OR (|bpSimpleDefinitionTail| |ps|) (|bpCompoundDefinitionTail| |ps| |f|))) -(DEFUN |bpWhere| () - (AND (|bpDefinition|) +(DEFUN |bpWhere| (|ps|) + (AND (|bpDefinition| |ps|) (OR - (AND (|bpEqKey| 'WHERE) (|bpRequire| #'|bpDefinitionItem|) - (|bpPush| (|bfWhere| (|bpPop1|) (|bpPop1|)))) + (AND (|bpEqKey| 'WHERE) (|bpRequire| |ps| #'|bpDefinitionItem|) + (|bpPush| |ps| (|bfWhere| (|bpPop1|) (|bpPop1|)))) T))) -(DEFUN |bpDefinitionItem| () +(DEFUN |bpDefinitionItem| (|ps|) (LET* (|a|) (PROGN (SETQ |a| (|bpState|)) - (COND ((|bpDDef|) T) + (COND ((|bpDDef| |ps|) T) (T (|bpRestore| |a|) - (COND ((|bpBDefinitionPileItems|) T) + (COND ((|bpBDefinitionPileItems| |ps|) T) (T (|bpRestore| |a|) - (COND ((|bpPDefinitionItems|) T) - (T (|bpRestore| |a|) (|bpWhere|)))))))))) + (COND ((|bpPDefinitionItems| |ps|) T) + (T (|bpRestore| |a|) (|bpWhere| |ps|)))))))))) -(DEFUN |bpDefinitionPileItems| () - (AND (|bpListAndRecover| #'|bpDefinitionItem|) - (|bpPush| (|%Pile| (|bpPop1|))))) +(DEFUN |bpDefinitionPileItems| (|ps|) + (AND (|bpListAndRecover| |ps| #'|bpDefinitionItem|) + (|bpPush| |ps| (|%Pile| (|bpPop1|))))) -(DEFUN |bpBDefinitionPileItems| () - (|bpPileBracketed| #'|bpDefinitionPileItems|)) +(DEFUN |bpBDefinitionPileItems| (|ps|) + (|bpPileBracketed| |ps| #'|bpDefinitionPileItems|)) -(DEFUN |bpSemiColonDefinition| () - (|bpSemiListing| #'|bpDefinitionItem| #'|%Pile|)) +(DEFUN |bpSemiColonDefinition| (|ps|) + (|bpSemiListing| |ps| #'|bpDefinitionItem| #'|%Pile|)) -(DEFUN |bpPDefinitionItems| () (|bpParenthesized| #'|bpSemiColonDefinition|)) +(DEFUN |bpPDefinitionItems| (|ps|) + (|bpParenthesized| |ps| #'|bpSemiColonDefinition|)) -(DEFUN |bpComma| () (OR (|bpModule|) (|bpImport|) (|bpTuple| #'|bpWhere|))) +(DEFUN |bpComma| (|ps|) + (OR (|bpModule| |ps|) (|bpImport| |ps|) (|bpTuple| |ps| #'|bpWhere|))) -(DEFUN |bpTuple| (|p|) (|bpListofFun| |p| #'|bpCommaBackSet| #'|bfTuple|)) +(DEFUN |bpTuple| (|ps| |p|) + (|bpListofFun| |ps| |p| #'|bpCommaBackSet| #'|bfTuple|)) -(DEFUN |bpCommaBackSet| () (AND (|bpEqKey| 'COMMA) (OR (|bpEqKey| 'BACKSET) T))) +(DEFUN |bpCommaBackSet| (|ps|) + (AND (|bpEqKey| 'COMMA) (OR (|bpEqKey| 'BACKSET) T))) -(DEFUN |bpSemiColon| () (|bpSemiListing| #'|bpComma| #'|bfSequence|)) +(DEFUN |bpSemiColon| (|ps|) (|bpSemiListing| |ps| #'|bpComma| #'|bfSequence|)) -(DEFUN |bpSemiListing| (|p| |f|) (|bpListofFun| |p| #'|bpSemiBackSet| |f|)) +(DEFUN |bpSemiListing| (|ps| |p| |f|) + (|bpListofFun| |ps| |p| #'|bpSemiBackSet| |f|)) -(DEFUN |bpSemiBackSet| () +(DEFUN |bpSemiBackSet| (|ps|) (AND (|bpEqKey| 'SEMICOLON) (OR (|bpEqKey| 'BACKSET) T))) -(DEFUN |bpPDefinition| () (|bpIndentParenthesized| #'|bpSemiColon|)) +(DEFUN |bpPDefinition| (|ps|) (|bpIndentParenthesized| |ps| #'|bpSemiColon|)) -(DEFUN |bpPileItems| () - (AND (|bpListAndRecover| #'|bpSemiColon|) - (|bpPush| (|bfSequence| (|bpPop1|))))) +(DEFUN |bpPileItems| (|ps|) + (AND (|bpListAndRecover| |ps| #'|bpSemiColon|) + (|bpPush| |ps| (|bfSequence| (|bpPop1|))))) -(DEFUN |bpBPileDefinition| () (|bpPileBracketed| #'|bpPileItems|)) +(DEFUN |bpBPileDefinition| (|ps|) (|bpPileBracketed| |ps| #'|bpPileItems|)) -(DEFUN |bpIteratorTail| () (AND (OR (|bpEqKey| 'REPEAT) T) (|bpIterators|))) +(DEFUN |bpIteratorTail| (|ps|) + (AND (OR (|bpEqKey| 'REPEAT) T) (|bpIterators| |ps|))) -(DEFUN |bpConstruct| () (|bpBracket| #'|bpConstruction|)) +(DEFUN |bpConstruct| (|ps|) (|bpBracket| |ps| #'|bpConstruction|)) -(DEFUN |bpConstruction| () - (AND (|bpComma|) +(DEFUN |bpConstruction| (|ps|) + (AND (|bpComma| |ps|) (OR - (AND (|bpIteratorTail|) (|bpPush| (|bfCollect| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfTupleConstruct| (|bpPop1|)))))) + (AND (|bpIteratorTail| |ps|) + (|bpPush| |ps| (|bfCollect| (|bpPop2|) (|bpPop1|)))) + (|bpPush| |ps| (|bfTupleConstruct| (|bpPop1|)))))) -(DEFUN |bpDConstruct| () (|bpBracket| #'|bpDConstruction|)) +(DEFUN |bpDConstruct| (|ps|) (|bpBracket| |ps| #'|bpDConstruction|)) -(DEFUN |bpDConstruction| () - (AND (|bpComma|) +(DEFUN |bpDConstruction| (|ps|) + (AND (|bpComma| |ps|) (OR - (AND (|bpIteratorTail|) - (|bpPush| (|bfDCollect| (|bpPop2|) (|bpPop1|)))) - (|bpPush| (|bfDTuple| (|bpPop1|)))))) - -(DEFUN |bpPattern| () - (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpChar|) (|bpName|) - (|bpConstTok|))) - -(DEFUN |bpEqual| () - (AND (|bpEqKey| 'SHOEEQ) (OR (|bpApplication|) (|bpConstTok|) (|bpTrap|)) - (|bpPush| (|bfEqual| (|bpPop1|))))) - -(DEFUN |bpRegularPatternItem| () - (OR (|bpEqual|) (|bpConstTok|) (|bpDot|) - (AND (|bpName|) + (AND (|bpIteratorTail| |ps|) + (|bpPush| |ps| (|bfDCollect| (|bpPop2|) (|bpPop1|)))) + (|bpPush| |ps| (|bfDTuple| (|bpPop1|)))))) + +(DEFUN |bpPattern| (|ps|) + (OR (|bpBracketConstruct| |ps| #'|bpPatternL|) (|bpChar| |ps|) + (|bpName| |ps|) (|bpConstTok| |ps|))) + +(DEFUN |bpEqual| (|ps|) + (AND (|bpEqKey| 'SHOEEQ) + (OR (|bpApplication| |ps|) (|bpConstTok| |ps|) (|bpTrap|)) + (|bpPush| |ps| (|bfEqual| (|bpPop1|))))) + +(DEFUN |bpRegularPatternItem| (|ps|) + (OR (|bpEqual| |ps|) (|bpConstTok| |ps|) (|bpDot| |ps|) + (AND (|bpName| |ps|) (OR - (AND (|bpEqKey| 'BEC) (|bpRequire| #'|bpPattern|) - (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'BEC) (|bpRequire| |ps| #'|bpPattern|) + (|bpPush| |ps| (|bfAssign| (|bpPop2|) (|bpPop1|)))) T)) - (|bpBracketConstruct| #'|bpPatternL|))) + (|bpBracketConstruct| |ps| #'|bpPatternL|))) -(DEFUN |bpRegularPatternItemL| () - (AND (|bpRegularPatternItem|) (|bpPush| (LIST (|bpPop1|))))) +(DEFUN |bpRegularPatternItemL| (|ps|) + (AND (|bpRegularPatternItem| |ps|) (|bpPush| |ps| (LIST (|bpPop1|))))) -(DEFUN |bpRegularList| () - (|bpListof| #'|bpRegularPatternItemL| 'COMMA #'|bfAppend|)) +(DEFUN |bpRegularList| (|ps|) + (|bpListof| |ps| #'|bpRegularPatternItemL| 'COMMA #'|bfAppend|)) -(DEFUN |bpPatternColon| () - (AND (|bpEqKey| 'COLON) (|bpRequire| #'|bpRegularPatternItem|) - (|bpPush| (LIST (|bfColon| (|bpPop1|)))))) +(DEFUN |bpPatternColon| (|ps|) + (AND (|bpEqKey| 'COLON) (|bpRequire| |ps| #'|bpRegularPatternItem|) + (|bpPush| |ps| (LIST (|bfColon| (|bpPop1|)))))) -(DEFUN |bpPatternL| () - (AND (|bpPatternList|) (|bpPush| (|bfTuple| (|bpPop1|))))) +(DEFUN |bpPatternL| (|ps|) + (AND (|bpPatternList| |ps|) (|bpPush| |ps| (|bfTuple| (|bpPop1|))))) -(DEFUN |bpPatternList| () +(DEFUN |bpPatternList| (|ps|) (COND - ((|bpRegularPatternItemL|) + ((|bpRegularPatternItemL| |ps|) (LOOP (COND ((NOT (AND (|bpEqKey| 'COMMA) - (OR (|bpRegularPatternItemL|) + (OR (|bpRegularPatternItemL| |ps|) (PROGN (OR - (AND (|bpPatternTail|) - (|bpPush| (|append| (|bpPop2|) (|bpPop1|)))) + (AND (|bpPatternTail| |ps|) + (|bpPush| |ps| (|append| (|bpPop2|) (|bpPop1|)))) (|bpTrap|)) NIL)))) (RETURN NIL)) - (T (|bpPush| (|append| (|bpPop2|) (|bpPop1|)))))) + (T (|bpPush| |ps| (|append| (|bpPop2|) (|bpPop1|)))))) T) - (T (|bpPatternTail|)))) + (T (|bpPatternTail| |ps|)))) -(DEFUN |bpPatternTail| () - (AND (|bpPatternColon|) +(DEFUN |bpPatternTail| (|ps|) + (AND (|bpPatternColon| |ps|) (OR - (AND (|bpEqKey| 'COMMA) (|bpRequire| #'|bpRegularList|) - (|bpPush| (|append| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'COMMA) (|bpRequire| |ps| #'|bpRegularList|) + (|bpPush| |ps| (|append| (|bpPop2|) (|bpPop1|)))) T))) -(DEFUN |bpRegularBVItemTail| () +(DEFUN |bpRegularBVItemTail| (|ps|) (OR - (AND (|bpEqKey| 'COLON) (|bpRequire| #'|bpApplication|) - (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) - (AND (|bpEqKey| 'BEC) (|bpRequire| #'|bpPattern|) - (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) - (AND (|bpEqKey| 'IS) (|bpRequire| #'|bpPattern|) - (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) - (AND (|bpEqKey| 'DEF) (|bpRequire| #'|bpApplication|) - (|bpPush| (|%DefaultValue| (|bpPop2|) (|bpPop1|)))))) - -(DEFUN |bpRegularBVItem| () - (OR (|bpBVString|) (|bpConstTok|) - (AND (|bpName|) (OR (|bpRegularBVItemTail|) T)) - (|bpBracketConstruct| #'|bpPatternL|))) - -(DEFUN |bpBVString| () + (AND (|bpEqKey| 'COLON) (|bpRequire| |ps| #'|bpApplication|) + (|bpPush| |ps| (|bfTagged| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'BEC) (|bpRequire| |ps| #'|bpPattern|) + (|bpPush| |ps| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'IS) (|bpRequire| |ps| #'|bpPattern|) + (|bpPush| |ps| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'DEF) (|bpRequire| |ps| #'|bpApplication|) + (|bpPush| |ps| (|%DefaultValue| (|bpPop2|) (|bpPop1|)))))) + +(DEFUN |bpRegularBVItem| (|ps|) + (OR (|bpBVString| |ps|) (|bpConstTok| |ps|) + (AND (|bpName| |ps|) (OR (|bpRegularBVItemTail| |ps|) T)) + (|bpBracketConstruct| |ps| #'|bpPatternL|))) + +(DEFUN |bpBVString| (|ps|) (DECLARE (SPECIAL |$ttok| |$stok|)) (AND (EQ (|tokenClass| |$stok|) 'STRING) - (|bpPush| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext|))) + (|bpPush| |ps| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext|))) -(DEFUN |bpRegularBVItemL| () - (AND (|bpRegularBVItem|) (|bpPush| (LIST (|bpPop1|))))) +(DEFUN |bpRegularBVItemL| (|ps|) + (AND (|bpRegularBVItem| |ps|) (|bpPush| |ps| (LIST (|bpPop1|))))) -(DEFUN |bpColonName| () - (AND (|bpEqKey| 'COLON) (OR (|bpName|) (|bpBVString|) (|bpTrap|)))) +(DEFUN |bpColonName| (|ps|) + (AND (|bpEqKey| 'COLON) (OR (|bpName| |ps|) (|bpBVString| |ps|) (|bpTrap|)))) -(DEFUN |bpBoundVariablelist| () +(DEFUN |bpBoundVariablelist| (|ps|) (COND - ((|bpRegularBVItemL|) + ((|bpRegularBVItemL| |ps|) (LOOP (COND ((NOT (AND (|bpEqKey| 'COMMA) - (OR (|bpRegularBVItemL|) + (OR (|bpRegularBVItemL| |ps|) (PROGN (OR - (AND (|bpColonName|) - (|bpPush| (|bfColonAppend| (|bpPop2|) (|bpPop1|)))) + (AND (|bpColonName| |ps|) + (|bpPush| |ps| + (|bfColonAppend| (|bpPop2|) (|bpPop1|)))) (|bpTrap|)) NIL)))) (RETURN NIL)) - (T (|bpPush| (|append| (|bpPop2|) (|bpPop1|)))))) + (T (|bpPush| |ps| (|append| (|bpPop2|) (|bpPop1|)))))) T) - (T (AND (|bpColonName|) (|bpPush| (|bfColonAppend| NIL (|bpPop1|))))))) + (T + (AND (|bpColonName| |ps|) + (|bpPush| |ps| (|bfColonAppend| NIL (|bpPop1|))))))) -(DEFUN |bpVariable| () +(DEFUN |bpVariable| (|ps|) (OR - (AND (|bpParenthesized| #'|bpBoundVariablelist|) - (|bpPush| (|bfTupleIf| (|bpPop1|)))) - (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) (|bpConstTok|))) - -(DEFUN |bpAssignVariable| () - (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpAssignLHS|))) - -(DEFUN |bpAssignLHS| () - (COND ((NOT (|bpName|)) NIL) - ((|bpEqKey| 'COLON) (|bpRequire| #'|bpApplication|) - (|bpPush| (|bfLocal| (|bpPop2|) (|bpPop1|)))) + (AND (|bpParenthesized| |ps| #'|bpBoundVariablelist|) + (|bpPush| |ps| (|bfTupleIf| (|bpPop1|)))) + (|bpBracketConstruct| |ps| #'|bpPatternL|) (|bpName| |ps|) + (|bpConstTok| |ps|))) + +(DEFUN |bpAssignVariable| (|ps|) + (OR (|bpBracketConstruct| |ps| #'|bpPatternL|) (|bpAssignLHS| |ps|))) + +(DEFUN |bpAssignLHS| (|ps|) + (COND ((NOT (|bpName| |ps|)) NIL) + ((|bpEqKey| 'COLON) (|bpRequire| |ps| #'|bpApplication|) + (|bpPush| |ps| (|bfLocal| (|bpPop2|) (|bpPop1|)))) (T - (AND (|bpArgumentList|) + (AND (|bpArgumentList| |ps|) (OR (|bpEqPeek| 'DOT) - (AND (|bpEqPeek| 'BEC) (|bpPush| (|bfPlace| (|bpPop1|)))) + (AND (|bpEqPeek| 'BEC) + (|bpPush| |ps| (|bfPlace| (|bpPop1|)))) (|bpTrap|))) (COND ((|bpEqKey| 'DOT) - (AND (|bpList| #'|bpPrimary| 'DOT) (|bpChecknull|) - (|bpPush| (|bfTuple| (CONS (|bpPop2|) (|bpPop1|)))))) + (AND (|bpList| |ps| #'|bpPrimary| 'DOT) (|bpChecknull| |ps|) + (|bpPush| |ps| (|bfTuple| (CONS (|bpPop2|) (|bpPop1|)))))) (T T))))) -(DEFUN |bpChecknull| () +(DEFUN |bpChecknull| (|ps|) (LET* (|a|) (PROGN (SETQ |a| (|bpPop1|)) - (COND ((NULL |a|) (|bpTrap|)) (T (|bpPush| |a|)))))) + (COND ((NULL |a|) (|bpTrap|)) (T (|bpPush| |ps| |a|)))))) -(DEFUN |bpStruct| () - (AND (|bpEqKey| 'STRUCTURE) (|bpRequire| #'|bpName|) - (OR (|bpEqKey| 'DEF) (|bpTrap|)) (OR (|bpRecord|) (|bpTypeList|)) - (|bpPush| (|%Structure| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpStruct| (|ps|) + (AND (|bpEqKey| 'STRUCTURE) (|bpRequire| |ps| #'|bpName|) + (OR (|bpEqKey| 'DEF) (|bpTrap|)) + (OR (|bpRecord| |ps|) (|bpTypeList| |ps|)) + (|bpPush| |ps| (|%Structure| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpRecord| () +(DEFUN |bpRecord| (|ps|) (LET* (|s|) (PROGN (SETQ |s| (|bpState|)) (COND - ((AND (|bpName|) (EQ (|bpPop1|) '|Record|)) - (AND (OR (|bpParenthesized| #'|bpFieldList|) (|bpTrap|)) - (|bpGlobalAccessors|) - (|bpPush| (|%Record| (|bfUntuple| (|bpPop2|)) (|bpPop1|))))) + ((AND (|bpName| |ps|) (EQ (|bpPop1|) '|Record|)) + (AND (OR (|bpParenthesized| |ps| #'|bpFieldList|) (|bpTrap|)) + (|bpGlobalAccessors| |ps|) + (|bpPush| |ps| (|%Record| (|bfUntuple| (|bpPop2|)) (|bpPop1|))))) (T (|bpRestore| |s|) NIL))))) -(DEFUN |bpFieldList| () (|bpTuple| #'|bpSignature|)) +(DEFUN |bpFieldList| (|ps|) (|bpTuple| |ps| #'|bpSignature|)) -(DEFUN |bpGlobalAccessors| () +(DEFUN |bpGlobalAccessors| (|ps|) (COND ((|bpEqKey| 'WITH) - (OR (|bpPileBracketed| #'|bpAccessorDefinitionList|) (|bpTrap|))) - (T (|bpPush| NIL)))) + (OR (|bpPileBracketed| |ps| #'|bpAccessorDefinitionList|) (|bpTrap|))) + (T (|bpPush| |ps| NIL)))) -(DEFUN |bpAccessorDefinitionList| () - (|bpListAndRecover| #'|bpAccessorDefinition|)) +(DEFUN |bpAccessorDefinitionList| (|ps|) + (|bpListAndRecover| |ps| #'|bpAccessorDefinition|)) -(DEFUN |bpAccessorDefinition| () - (AND (|bpRequire| #'|bpName|) (OR (|bpEqKey| 'DEF) (|bpTrap|)) - (|bpRequire| #'|bpFieldSection|) - (|bpPush| (|%AccessorDef| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpAccessorDefinition| (|ps|) + (AND (|bpRequire| |ps| #'|bpName|) (OR (|bpEqKey| 'DEF) (|bpTrap|)) + (|bpRequire| |ps| #'|bpFieldSection|) + (|bpPush| |ps| (|%AccessorDef| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpFieldSection| () (|bpParenthesized| #'|bpSelectField|)) +(DEFUN |bpFieldSection| (|ps|) (|bpParenthesized| |ps| #'|bpSelectField|)) -(DEFUN |bpSelectField| () (AND (|bpEqKey| 'DOT) (|bpName|))) +(DEFUN |bpSelectField| (|ps|) (AND (|bpEqKey| 'DOT) (|bpName| |ps|))) -(DEFUN |bpTypeList| () - (OR (|bpPileBracketed| #'|bpTypeItemList|) - (AND (|bpTypeItem|) (|bpPush| (LIST (|bpPop1|)))))) +(DEFUN |bpTypeList| (|ps|) + (OR (|bpPileBracketed| |ps| #'|bpTypeItemList|) + (AND (|bpTypeItem| |ps|) (|bpPush| |ps| (LIST (|bpPop1|)))))) -(DEFUN |bpTypeItem| () (|bpTerm| #'|bpIdList|)) +(DEFUN |bpTypeItem| (|ps|) (|bpTerm| |ps| #'|bpIdList|)) -(DEFUN |bpTypeItemList| () (|bpListAndRecover| #'|bpTypeItem|)) +(DEFUN |bpTypeItemList| (|ps|) (|bpListAndRecover| |ps| #'|bpTypeItem|)) -(DEFUN |bpTerm| (|idListParser|) +(DEFUN |bpTerm| (|ps| |idListParser|) (OR - (AND (|bpRequire| #'|bpName|) + (AND (|bpRequire| |ps| #'|bpName|) (OR - (AND (|bpParenthesized| |idListParser|) - (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))) - (AND (|bpName|) (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))))) - (|bpPush| (|bfNameOnly| (|bpPop1|))))) + (AND (|bpParenthesized| |ps| |idListParser|) + (|bpPush| |ps| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))) + (AND (|bpName| |ps|) + (|bpPush| |ps| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))))) + (|bpPush| |ps| (|bfNameOnly| (|bpPop1|))))) -(DEFUN |bpIdList| () (|bpTuple| #'|bpName|)) +(DEFUN |bpIdList| (|ps|) (|bpTuple| |ps| #'|bpName|)) -(DEFUN |bpCase| () - (AND (|bpEqKey| 'CASE) (|bpRequire| #'|bpWhere|) - (OR (|bpEqKey| 'OF) (|bpMissing| 'OF)) (|bpPiledCaseItems|))) +(DEFUN |bpCase| (|ps|) + (AND (|bpEqKey| 'CASE) (|bpRequire| |ps| #'|bpWhere|) + (OR (|bpEqKey| 'OF) (|bpMissing| 'OF)) (|bpPiledCaseItems| |ps|))) -(DEFUN |bpPiledCaseItems| () - (AND (|bpPileBracketed| #'|bpCaseItemList|) - (|bpPush| (|bfCase| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpPiledCaseItems| (|ps|) + (AND (|bpPileBracketed| |ps| #'|bpCaseItemList|) + (|bpPush| |ps| (|bfCase| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpCaseItemList| () (|bpListAndRecover| #'|bpCaseItem|)) +(DEFUN |bpCaseItemList| (|ps|) (|bpListAndRecover| |ps| #'|bpCaseItem|)) -(DEFUN |bpCasePatternVar| () (OR (|bpName|) (|bpDot|))) +(DEFUN |bpCasePatternVar| (|ps|) (OR (|bpName| |ps|) (|bpDot| |ps|))) -(DEFUN |bpCasePatternVarList| () (|bpTuple| #'|bpCasePatternVar|)) +(DEFUN |bpCasePatternVarList| (|ps|) (|bpTuple| |ps| #'|bpCasePatternVar|)) -(DEFUN |bpCaseItem| () - (AND (OR (|bpTerm| #'|bpCasePatternVarList|) (|bpTrap|)) - (OR (|bpEqKey| 'EXIT) (|bpTrap|)) (|bpRequire| #'|bpWhere|) - (|bpPush| (|bfCaseItem| (|bpPop2|) (|bpPop1|))))) +(DEFUN |bpCaseItem| (|ps|) + (AND (OR (|bpTerm| |ps| #'|bpCasePatternVarList|) (|bpTrap|)) + (OR (|bpEqKey| 'EXIT) (|bpTrap|)) (|bpRequire| |ps| #'|bpWhere|) + (|bpPush| |ps| (|bfCaseItem| (|bpPop2|) (|bpPop1|))))) -(DEFUN |bpOutItem| () - (LET* (|r| |ISTMP#2| |l| |ISTMP#1| |b|) +(DEFUN |bpOutItem| (|ps|) + (LET* (|t| |r| |ISTMP#2| |l| |ISTMP#1| |b|) (DECLARE (SPECIAL |$InteractiveMode|)) (LET* ((|$op| NIL) (|$GenVarCounter| 0)) (DECLARE (SPECIAL |$op| |$GenVarCounter|)) (PROGN - (|bpRequire| #'|bpComma|) + (|bpRequire| |ps| #'|bpComma|) (SETQ |b| (|bpPop1|)) - (|bpPush| - (COND ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|)) - ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T) - (PROGN - (SETQ |ISTMP#1| (CDR |b|)) - (AND (CONSP |ISTMP#1|) - (PROGN - (SETQ |l| (CAR |ISTMP#1|)) - (SETQ |ISTMP#2| (CDR |ISTMP#1|)) - (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) - (PROGN (SETQ |r| (CAR |ISTMP#2|)) T))))) - (SYMBOLP |l|)) - (COND (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|))) - (T (LIST (LIST 'DEFPARAMETER |l| |r|))))) - (T (|translateToplevel| |b| NIL)))))))) + (SETQ |t| + (COND ((AND (CONSP |b|) (EQ (CAR |b|) '+LINE)) (LIST |b|)) + ((AND (CONSP |b|) (EQ (CAR |b|) 'L%T) + (PROGN + (SETQ |ISTMP#1| (CDR |b|)) + (AND (CONSP |ISTMP#1|) + (PROGN + (SETQ |l| (CAR |ISTMP#1|)) + (SETQ |ISTMP#2| (CDR |ISTMP#1|)) + (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|)) + (PROGN (SETQ |r| (CAR |ISTMP#2|)) T))))) + (SYMBOLP |l|)) + (COND (|$InteractiveMode| (LIST (LIST 'SETQ |l| |r|))) + (T (LIST (LIST 'DEFPARAMETER |l| |r|))))) + (T (|translateToplevel| |b| NIL)))) + (|bpPush| |ps| |t|))))) diff --git a/src/boot/strap/translator.clisp b/src/boot/strap/translator.clisp index 37d7aa38..d71a5351 100644 --- a/src/boot/strap/translator.clisp +++ b/src/boot/strap/translator.clisp @@ -431,13 +431,14 @@ (DEFUN |shoeAddComment| (|l|) (CONCAT "; " (CAR |l|))) -(DEFUN |shoeOutParse| (|stream|) - (LET* (|found|) +(DEFUN |shoeOutParse| (|toks|) + (LET* (|found| |ps|) (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$returns| |$typings| |$wheredefs| |$op| |$ttok| |$stok| |$stack| |$inputStream|)) (PROGN - (SETQ |$inputStream| |stream|) + (SETQ |$inputStream| |toks|) + (SETQ |ps| (|makeParserState| |toks|)) (SETQ |$stack| NIL) (SETQ |$stok| NIL) (SETQ |$ttok| NIL) @@ -449,7 +450,8 @@ (SETQ |$bpParenCount| 0) (|bpFirstTok|) (SETQ |found| - (LET ((#1=#:G729 (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem|)))) + (LET ((#1=#:G729 + (CATCH :OPEN-AXIOM-CATCH-POINT (|bpOutItem| |ps|)))) (COND ((AND (CONSP #1#) (EQUAL (CAR #1#) :OPEN-AXIOM-CATCH-POINT)) (COND @@ -1196,23 +1198,25 @@ (DEFUN BOOTLOOP () (LET* (|stream| |a|) + (DECLARE (SPECIAL |$stdio| |$stdin|)) (PROGN - (SETQ |a| (|readLine| *STANDARD-INPUT*)) + (SETQ |a| (|readLine| |$stdin|)) (COND ((EQL (LENGTH |a|) 0) (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTLOOP)) - ((|shoePrefix?| ")console" |a|) (SETQ |stream| *TERMINAL-IO*) + ((|shoePrefix?| ")console" |a|) (SETQ |stream| |$stdio|) (PSTTOMC (|bRgen| |stream|)) (BOOTLOOP)) ((CHAR= (SCHAR |a| 0) (|char| '])) NIL) (T (PSTTOMC (LIST |a|)) (BOOTLOOP)))))) (DEFUN BOOTPO () (LET* (|stream| |a|) + (DECLARE (SPECIAL |$stdio| |$stdin|)) (PROGN - (SETQ |a| (|readLine| *STANDARD-INPUT*)) + (SETQ |a| (|readLine| |$stdin|)) (COND ((EQL (LENGTH |a|) 0) (WRITE-LINE "Boot Loop; to exit type ] ") (BOOTPO)) - ((|shoePrefix?| ")console" |a|) (SETQ |stream| *TERMINAL-IO*) + ((|shoePrefix?| ")console" |a|) (SETQ |stream| |$stdio|) (PSTOUT (|bRgen| |stream|)) (BOOTPO)) ((CHAR= (SCHAR |a| 0) (|char| '])) NIL) (T (PSTOUT (LIST |a|)) (BOOTPO)))))) diff --git a/src/boot/strap/utility.clisp b/src/boot/strap/utility.clisp index daec2a91..20efc228 100644 --- a/src/boot/strap/utility.clisp +++ b/src/boot/strap/utility.clisp @@ -22,7 +22,8 @@ |symbolAssoc| |applySubst| |applySubst!| |applySubstNQ| |objectAssoc| |remove| |removeSymbol| |atomic?| |every?| |any?| |take| |takeWhile| |drop| |copyTree| |finishLine| - |stringSuffix?| |findChar| |charPosition|))) + |stringPrefix?| |stringSuffix?| |findChar| + |charPosition|))) (DECLAIM (FTYPE (FUNCTION (|%Thing| |%Thing| |%Thing|) |%Thing|) |substitute|)) @@ -106,6 +107,9 @@ (DECLAIM (FTYPE (FUNCTION (|%String| |%String|) (|%Maybe| |%Short|)) |stringSuffix?|)) +(DECLAIM + (FTYPE (FUNCTION (|%String| |%String|) (|%Maybe| |%Short|)) |stringPrefix?|)) + (|%defaultReadAndLoadSettings|) (DEFUN |atomic?| (|x|) (OR (NOT (CONSP |x|)) (EQ (CAR |x|) 'QUOTE))) @@ -493,5 +497,19 @@ |n|) (T NIL))))))) +(DEFUN |stringPrefix?| (|s1| |s2|) + (LET* (|n1|) + (PROGN + (SETQ |n1| (LENGTH |s1|)) + (COND ((< (LENGTH |s2|) |n1|) NIL) + ((LET ((|bfVar#2| T) (|bfVar#1| (- |n1| 1)) (|i| 0)) + (LOOP + (COND ((> |i| |bfVar#1|) (RETURN |bfVar#2|)) + (T (SETQ |bfVar#2| (EQUAL (ELT |s1| |i|) (ELT |s2| |i|))) + (COND ((NOT |bfVar#2|) (RETURN NIL))))) + (SETQ |i| (+ |i| 1)))) + |n1|) + (T NIL))))) + (DEFUN |finishLine| (|out|) (PROGN (TERPRI |out|) (FORCE-OUTPUT |out|))) diff --git a/src/boot/translator.boot b/src/boot/translator.boot index 2302582d..d103351e 100644 --- a/src/boot/translator.boot +++ b/src/boot/translator.boot @@ -354,8 +354,9 @@ shoeConsoleTrees s == shoeAddComment l== strconc('"; ", first l) -shoeOutParse stream == - $inputStream := stream +shoeOutParse toks == + $inputStream := toks + ps := makeParserState toks $stack := [] $stok := nil $ttok := nil @@ -367,7 +368,7 @@ shoeOutParse stream == $bpParenCount := 0 bpFirstTok() found := - try bpOutItem() + try bpOutItem ps catch(e: BootParserException) => e found = 'TRAPPED => nil not bStreamNull $inputStream => diff --git a/src/interp/spad-parser.boot b/src/interp/spad-parser.boot index 266d966c..ff9051ed 100644 --- a/src/interp/spad-parser.boot +++ b/src/interp/spad-parser.boot @@ -48,7 +48,6 @@ namespace BOOT module spad_-parser where indentationLocation: %String -> %Maybe %Short - stringPrefix?: (%String,%String) -> %Boolean --% @@ -79,12 +78,6 @@ indentationLocation line == tabChar? line.i => loc := 8 * (loc quo 8 + 1) return loc -++ Return true if the string `s1' is a prefix of `s2'. -stringPrefix?(s1,s2) == - n1 := #s1 - n1 > #s2 => false - and/[s1.i = s2.i for i in 0..(n1-1)] - skipIfBlock x == [n,:line] := z := preparseReadLine1 x not string? line => z |