diff options
Diffstat (limited to 'src/boot/parser.boot.pamphlet')
| -rw-r--r-- | src/boot/parser.boot.pamphlet | 2453 |
1 files changed, 2453 insertions, 0 deletions
diff --git a/src/boot/parser.boot.pamphlet b/src/boot/parser.boot.pamphlet new file mode 100644 index 00000000..043dde0f --- /dev/null +++ b/src/boot/parser.boot.pamphlet @@ -0,0 +1,2453 @@ +\documentclass{article} +\usepackage{axiom} +\usepackage{fancyvrb} + +\CustomVerbatimEnvironment{Grammar}{Verbatim}% + {frame=none,fontsize=\small,commandchars=\\\{\}} +\newcommand{\production}[1]{{\rmfamily\itshape{#1}}} +\newcommand{\Terminal}[1]{\ensuremath{\mathbf{#1}}} +\newcommand{\Bar}{\ensuremath{\mid}} +\newcommand{\Comment}[1]{-- \textrm{#1}} + +\title{\File{src/boot/parser.boot} Pamphlet} +\author{The Axiom Team} + +\begin{document} +\maketitle + +\begin{abstract} + This file defines the Boot grammar and parser. The parser + is hand-written based on \emph{parser combinators} technology. +\end{abstract} + +\tableofcontents +\eject + +\section{Introduction} +\label{sec:intro} + +This file defines the grammar, and implements the parser for the +Boot language. The parser is +recursive descent and uses \emph{parser combinators} techniques. + +\section{The Parser} +\label{sec:parser} + + +\subsection{Names} +\label{sec:parser:name} + +\begin{Grammar} + \production{Name:} + \Terminal{ID} + \production{Name} :: \Terminal{ID} +\end{Grammar} + +<<Name>>= +-- A fully qualified name could be interpreted as a left reduction +-- of an '::' infix operator. At the moment, we don't use +-- that general interpretation. + +-- When this routine is called, a symbol is already pushed on the +-- stack. When this routine finished execution, we have either +-- reduced a '::' and a name, or nothing. In either case, a +-- symbol is present on the stack. +bpQualifiedName() == + bpEqPeek "COLON-COLON" => + bpNext() + EQCAR($stok, "ID") and bpPushId() and bpNext() + and bpPush bfColonColon(bpPop2(), bpPop1()) + false + +bpName() == + EQCAR( $stok,"ID") => + bpPushId() + bpNext() + bpAnyNo function bpQualifiedName + false +@ + + +\subsection{Constants} +\label{sec:parser:constant} + +\begin{Grammar} + \production{Constant:} + \Terminal{INTEGER} + \Bar \Terminal{FLOAT} + \Bar \Terminal{LISP} + \Bar \Terminal{LISPEXPR} + \Bar \Terminal{LINE} + \Bar \Terminal{QUOTE} \production{S-Expression} + \Bar \Terminal{STRING} +\end{Grammar} + +<<Constant>>= +bpConstTok() == + MEMQ(shoeTokType $stok, '(INTEGER FLOAT)) => + bpPush $ttok + bpNext() + EQCAR($stok,"LISP")=> bpPush bfReadLisp $ttok and bpNext() + EQCAR($stok,"LISPEXP")=> bpPush $ttok and bpNext() + EQCAR($stok,"LINE")=> bpPush ["+LINE", $ttok] and bpNext() + bpEqPeek "QUOTE" => + bpNext() + (bpSexp() or bpTrap()) and + bpPush bfSymbol bpPop1() + bpString() +@ + +\subsection{Wildchar} +\label{sec:parser:dot} + +The dot character (\verb!.!) is used both as a selection operator and +as wild character in patterns. +\begin{Grammar} + \production{Dot:} + \Terminal{DOT} +\end{Grammar} + +<<Dot>>= +bpDot()== bpEqKey "DOT" and bpPush bfDot () +@ + + +\subsection{Prefix operators} +\label{sec:parser:prefix-op} + +Boot has two prefix operators. +\begin{Grammar} + \production{PrefixOperator:} \textrm{one of} + ^ # +\end{Grammar} + +<<PrefixOperator>>= +bpPrefixOperator()== + EQCAR( $stok,"KEY") and + GET($ttok,"SHOEPRE") and bpPushId() and bpNext() +@ + +\subsection{Infix operators} +\label{sec:parser:infix-op} + +\begin{Grammar} + \production{InfixOperator:} \textrm{one of} + = * + is isnt and or / ** - < > <= >= ^= +\end{Grammar} + +<<InfixOperator>>= +bpInfixOperator()== + EQCAR( $stok,"KEY") and + GET($ttok,"SHOEINF") and bpPushId() and bpNext() +@ + +\section{License} + +<<license>>= +-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd. +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are +-- met: +-- +-- - Redistributions of source code must retain the above copyright +-- notice, this list of conditions and the following disclaimer. +-- +-- - Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in +-- the documentation and/or other materials provided with the +-- distribution. +-- +-- - Neither the name of The Numerical ALgorithms Group Ltd. nor the +-- names of its contributors may be used to endorse or promote products +-- derived from this software without specific prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +@ +<<*>>= +<<license>> + +module '"boot-parser" +import '"includer" +import '"scanner" +import '"ast" + +)package "BOOTTRAN" + + +++ true when the current function definition has its parameters +++ written round parenthesis. +$sawParenthesizedHead := false + +++ true if the current function definition has a return statement. +$bodyHasReturn := false + + +bpFirstToken()== + $stok:= + if null $inputStream + then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) + else CAR $inputStream + $ttok:=shoeTokPart $stok + true + +bpFirstTok()== + $stok:= + if null $inputStream + then shoeTokConstruct("ERROR","NOMORE",shoeTokPosn $stok) + else CAR $inputStream + $ttok:=shoeTokPart $stok + $bpParenCount>0 and EQCAR($stok,"KEY") => + EQ($ttok,"SETTAB")=> + $bpCount:=$bpCount+1 + bpNext() + EQ($ttok,"BACKTAB")=> + $bpCount:=$bpCount-1 + bpNext() + EQ($ttok,"BACKSET")=> + bpNext() + true + true + +bpNext() == + $inputStream := CDR($inputStream) + bpFirstTok() + +bpNextToken() == + $inputStream := CDR($inputStream) + bpFirstToken() + +bpState()== [$inputStream,$stack,$bpParenCount,$bpCount] +--cons($inputStream,$stack) + +bpRestore(x)== + $inputStream:=CAR x + bpFirstToken() + $stack:=CADR x + $bpParenCount:=CADDR x + $bpCount:=CADDDR x + true + +bpPush x==$stack:=CONS(x,$stack) + +bpPushId()== + $stack:=CONS(bfReName $ttok,$stack) + +bpPop1()== + a:=CAR $stack + $stack:=CDR $stack + a + +bpPop2()== + a:=CADR $stack + RPLACD($stack,CDDR $stack) + a + +bpPop3()== + a:=CADDR $stack + RPLACD(CDR $stack,CDDDR $stack) + a + +bpIndentParenthesized f== + $bpCount:local:=0 + a:=$stok + if bpEqPeek "OPAREN" + then + $bpParenCount:=$bpParenCount+1 + bpNext() + if APPLY(f,nil) and bpFirstTok() and + (bpEqPeek "CPAREN" or bpParenTrap(a)) + then + $bpParenCount:=$bpParenCount-1 + bpNextToken() + $bpCount=0 => true + $inputStream:=append( bpAddTokens $bpCount,$inputStream) + bpFirstToken() + $bpParenCount=0 => + bpCancel() + true + true + else if bpEqPeek "CPAREN" + then + bpPush bfTuple [] + $bpParenCount:=$bpParenCount-1 + bpNextToken() + true + else bpParenTrap(a) + else false + +bpParenthesized f== + a:=$stok + if bpEqKey "OPAREN" + then + if APPLY(f,nil) and (bpEqKey "CPAREN" or bpParenTrap(a)) + then true + else if bpEqKey "CPAREN" + then + bpPush bfTuple [] + true + else bpParenTrap(a) + else false + +bpBracket f== + a:=$stok + if bpEqKey "OBRACK" + then + if APPLY(f,nil) and (bpEqKey "CBRACK" or bpBrackTrap(a)) + then bpPush bfBracket bpPop1 () + else if bpEqKey "CBRACK" + then bpPush [] + else bpBrackTrap(a) + else false + +bpPileBracketed f== + if bpEqKey "SETTAB" + then if bpEqKey "BACKTAB" + then true + else if APPLY(f,nil) and + (bpEqKey "BACKTAB" or bpPileTrap()) + then bpPush bfPile bpPop1() + else false + else false + +bpListof(f,str1,g)== + if APPLY(f,nil) + then + if bpEqKey str1 and (APPLY(f,nil) or bpTrap()) + then + a:=$stack + $stack:=nil + while bpEqKey str1 and (APPLY(f,nil) or bpTrap()) repeat 0 + $stack:=cons(NREVERSE $stack,a) + bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()]) + else + true + else false + + +-- to do ,<backset> +bpListofFun(f,h,g)== + if APPLY(f,nil) + then + if APPLY(h,nil) and (APPLY(f,nil) or bpTrap()) + then + a:=$stack + $stack:=nil + while APPLY(h,nil) and (APPLY(f,nil) or bpTrap()) repeat 0 + $stack:=cons(NREVERSE $stack,a) + bpPush FUNCALL(g, bfListOf [bpPop3(),bpPop2(),:bpPop1()]) + else + true + else false + +bpList(f,str1,g)== + if APPLY(f,nil) + then + if bpEqKey str1 and (APPLY(f,nil) or bpTrap()) + then + a:=$stack + $stack:=nil + while bpEqKey str1 and (APPLY(f,nil) or bpTrap()) repeat 0 + $stack:=cons(NREVERSE $stack,a) + bpPush FUNCALL(g, [bpPop3(),bpPop2(),:bpPop1()]) + else + bpPush FUNCALL(g, [bpPop1()]) + else bpPush FUNCALL(g, []) + +bpOneOrMore f== + APPLY(f,nil)=> + a:=$stack + $stack:=nil + while APPLY(f,nil) repeat 0 + $stack:=cons(NREVERSE $stack,a) + bpPush cons(bpPop2(),bpPop1()) + false + + +-- s must transform the head of the stack +bpAnyNo s== + while APPLY(s,nil) repeat 0 + true + + +-- AndOr(k,p,f)= k p +bpAndOr(keyword,p,f)== + bpEqKey keyword and (APPLY(p,nil) or bpTrap()) + and bpPush FUNCALL(f, bpPop1()) + +bpConditional f== + if bpEqKey "IF" and (bpWhere() or bpTrap()) and + (bpEqKey "BACKSET" or true) + then + if bpEqKey "SETTAB" + then if bpEqKey "THEN" + then (APPLY(f,nil) or bpTrap()) and bpElse(f) and bpEqKey "BACKTAB" + else bpMissing "THEN" + else if bpEqKey "THEN" + then (APPLY(f,nil) or bpTrap()) and bpElse(f) + else bpMissing "then" + else false + +bpElse(f)== + a:=bpState() + if bpBacksetElse() + then (APPLY(f,nil) or bpTrap()) and + bpPush bfIf(bpPop3(),bpPop2(),bpPop1()) + else + bpRestore a + bpPush bfIfThenOnly(bpPop2(),bpPop1()) + +bpBacksetElse()== + if bpEqKey "BACKSET" + then bpEqKey "ELSE" + else bpEqKey "ELSE" + +bpEqPeek s == EQCAR($stok,"KEY") and EQ(s,$ttok) + +bpEqKey s == EQCAR($stok,"KEY") and EQ(s,$ttok) and bpNext() +bpEqKeyNextTok s == EQCAR($stok,"KEY") and EQ(s,$ttok) and + bpNextToken() + +bpPileTrap() == bpMissing "BACKTAB" +bpBrackTrap(x) == bpMissingMate("]",x) +bpParenTrap(x) == bpMissingMate(")",x) + +bpMissingMate(close,open)== + bpSpecificErrorAtToken(open, '"possibly missing mate") + bpMissing close + +bpMissing s== + bpSpecificErrorHere(CONCAT(PNAME s,'" possibly missing")) + THROW("TRAPPOINT","TRAPPED") + +bpCompMissing s == bpEqKey s or bpMissing s + +bpTrap()== + bpGeneralErrorHere() + THROW("TRAPPOINT","TRAPPED") + +bpRecoverTrap()== + bpFirstToken() + pos1 := shoeTokPosn $stok + bpMoveTo 0 + pos2 := shoeTokPosn $stok + bpIgnoredFromTo(pos1, pos2) + bpPush [['"pile syntax error"]] + +bpListAndRecover(f)== + a:=$stack + b:=nil + $stack:=nil + done:=false + c:=$inputStream + while not done repeat +-- $trapped:local:=false + found:=CATCH("TRAPPOINT",APPLY(f,nil)) + if found="TRAPPED" + then + $inputStream:=c + bpRecoverTrap() + else if not found + then + $inputStream:=c + bpGeneralErrorHere() + bpRecoverTrap() + if bpEqKey "BACKSET" + then + c:=$inputStream + else if bpEqPeek "BACKTAB" or null $inputStream + then + done:=true + else + $inputStream:=c + bpGeneralErrorHere() + bpRecoverTrap() + if bpEqPeek "BACKTAB" or null $inputStream + then done:=true + else + bpNext() + c:=$inputStream + b:=cons(bpPop1(),b) + $stack:=a + bpPush NREVERSE b + +bpMoveTo n== + null $inputStream => true + bpEqPeek "BACKTAB" => + n=0 => true + bpNextToken() + $bpCount:=$bpCount-1 + bpMoveTo(n-1) + bpEqPeek "BACKSET" => + n=0 => true + bpNextToken() + bpMoveTo n + bpEqPeek "SETTAB" => + bpNextToken() + bpMoveTo(n+1) + bpEqPeek "OPAREN" => + bpNextToken() + $bpParenCount:=$bpParenCount+1 + bpMoveTo n + bpEqPeek "CPAREN" => + bpNextToken() + $bpParenCount:=$bpParenCount-1 + bpMoveTo n + bpNextToken() + bpMoveTo n + +<<Name>> + +<<Constant>> + +bpModule() == + bpEqKey "MODULE" => + -- we really want to check that the next token is indeed + -- a string. For the moment, we delay the type checking + -- to the Lisp compiler/interpreter. That is likely to + -- cause cryptic diagnostics. To be fixed. + bpConstTok() and bpPush Module bpPop1() + false + +bpImport() == + bpEqKey "IMPORT" => + -- we really want to check that the next token is indeed + -- a string. For the moment, we delay the type checking + -- to the Lisp compiler/interpreter. That is likely to + -- cause cryptic diagnostics. To be fixed. + bpConstTok() and bpPush Import bpPop1() + false + + +-- Parse a type alias defnition: +-- type-alias-definition: +-- identifier <=> logical-expression +bpTypeAliasDefition() == + (bpName() or bpTrap()) and + bpEqKey "TDEF" and bpLogical() and + bpPush TypeAlias(bpPop2(), nil, bpPop1()) + +bpCancel()== + a:=bpState() + if bpEqKeyNextTok "SETTAB" + then if bpCancel() + then if bpEqKeyNextTok "BACKTAB" + then true + else + bpRestore a + false + else + if bpEqKeyNextTok "BACKTAB" + then true + else + bpRestore a + false + else false +bpAddTokens n== + n=0 => nil + n>0=> cons(shoeTokConstruct("KEY","SETTAB",shoeTokPosn $stok),bpAddTokens(n-1)) + cons(shoeTokConstruct("KEY","BACKTAB",shoeTokPosn $stok),bpAddTokens(n+1)) + +bpExceptions()== + bpEqPeek "DOT" or bpEqPeek "QUOTE" or + bpEqPeek "OPAREN" or bpEqPeek "CPAREN" or + bpEqPeek "SETTAB" or bpEqPeek "BACKTAB" + or bpEqPeek "BACKSET" + + +bpSexpKey()== + EQCAR( $stok,"KEY") and not bpExceptions()=> + a:=GET($ttok,"SHOEINF") + null a=> bpPush $ttok and bpNext() + bpPush a and bpNext() + false + +bpAnyId()== + bpEqKey "MINUS" and (EQCAR($stok,"INTEGER") or bpTrap()) and + bpPush MINUS $ttok and bpNext() or + bpSexpKey() or + MEMQ(shoeTokType $stok, '(ID INTEGER STRING FLOAT)) + and bpPush $ttok and bpNext() + +bpSexp()== + bpAnyId() or + bpEqKey "QUOTE" and (bpSexp() or bpTrap()) + and bpPush bfSymbol bpPop1() or + bpIndentParenthesized function bpSexp1 + +bpSexp1()== bpFirstTok() and + bpSexp() and + (bpEqKey "DOT" and bpSexp() and bpPush CONS (bpPop2(),bpPop1())or + bpSexp1() and bpPush CONS (bpPop2(),bpPop1())) or + bpPush nil + +bpPrimary1() == + bpName() or + bpDot() or + bpConstTok() or + bpConstruct() or + bpCase() or + bpStruct() or + bpPDefinition() or + bpBPileDefinition() + +bpPrimary()== bpFirstTok() and (bpPrimary1() or bpPrefixOperator()) + +<<Dot>> + +<<PrefixOperator>> + +<<InfixOperator>> + +bpSelector()== + bpEqKey "DOT" and (bpPrimary() + and bpPush(bfElt(bpPop2(),bpPop1())) + or bpPush bfSuffixDot bpPop1() ) + +bpOperator()== bpPrimary() and bpAnyNo function bpSelector + +bpApplication()== + bpPrimary() and bpAnyNo function bpSelector and + (bpApplication() and + bpPush(bfApplication(bpPop2(),bpPop1())) or true) + +bpTagged()== + bpApplication() and + (bpEqKey "COLON" and (bpApplication() or bpTrap()) and + bpPush bfTagged(bpPop2(),bpPop1()) or true) + +bpExpt()== bpRightAssoc('(POWER),function bpTagged) + +bpInfKey s== + EQCAR( $stok,"KEY") and + MEMBER($ttok,s) and bpPushId() and bpNext() + +bpInfGeneric s== bpInfKey s and (bpEqKey "BACKSET" or true) + +bpRightAssoc(o,p)== + a:=bpState() + if APPLY(p,nil) + then + while bpInfGeneric o and (bpRightAssoc(o,p) or bpTrap()) repeat + bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) + true + else + bpRestore a + false + +bpLeftAssoc(operations,parser)== + if APPLY(parser,nil) + then + while bpInfGeneric(operations) and + (APPLY(parser,nil) or bpTrap()) + repeat + bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) + true + else false + +bpString()== + EQ(shoeTokType $stok,"STRING") and + bpPush(["QUOTE",INTERN $ttok]) and bpNext() + +bpThetaName() == + if EQCAR( $stok,"ID") and GET($ttok,"SHOETHETA") + then + bpPushId() + bpNext() + else false + +bpReduceOperator()== + bpInfixOperator() or bpString() + or bpThetaName() + +bpReduce()== + a:=bpState() + if bpReduceOperator() and bpEqKey "SLASH" + then + bpEqPeek "OBRACK" => (bpDConstruct() or bpTrap()) and + bpPush bfReduceCollect(bpPop2(),bpPop1()) + (bpApplication() or bpTrap()) and + bpPush bfReduce(bpPop2(),bpPop1()) + else + bpRestore a + false + +bpTimes()== + bpReduce() or bpLeftAssoc('(TIMES SLASH),function bpExpt) + +bpMinus()== + bpInfGeneric '(MINUS) and (bpTimes() or bpTrap()) + and bpPush(bfApplication(bpPop2(),bpPop1())) + or bpTimes() + +bpArith()==bpLeftAssoc('(PLUS MINUS),function bpMinus) + +bpIs()== + bpArith() and (bpInfKey '(IS ISNT) and (bpPattern() or bpTrap()) + and bpPush bfISApplication(bpPop2(),bpPop2(),bpPop1()) + or true) + +bpBracketConstruct(f)== + bpBracket f and bpPush bfConstruct bpPop1 () + +bpCompare()== + bpIs() and (bpInfKey '(SHOEEQ NE LT LE GT GE IN) + and (bpIs() or bpTrap()) + and bpPush bfInfApplication(bpPop2(),bpPop2(),bpPop1()) + or true) + +bpAnd()== bpLeftAssoc('(AND),function bpCompare) + + +++ Note the fact that a return statement is used in the body +++ of current function definition. +bpNoteReturnStmt() == + $bodyHasReturn := true + true + +bpReturn()== + (bpEqKey "RETURN" and bpNoteReturnStmt() and + (bpAnd() or bpTrap()) and + bpPush bfReturnNoName bpPop1()) or bpAnd() + + +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() + +bpLoop()== + bpIterators() and + (bpCompMissing "REPEAT" and + (bpWhere() or bpTrap()) and + bpPush bfLp(bpPop2(),bpPop1())) + or + bpEqKey "REPEAT" and (bpLogical() or bpTrap()) and + bpPush bfLoop1 bpPop1 () + +bpSuchThat()==bpAndOr("BAR",function bpWhere,function bfSuchthat) + +bpWhile()==bpAndOr ("WHILE",function bpLogical,function bfWhile) + +bpUntil()==bpAndOr ("UNTIL",function bpLogical,function bfUntil) + +bpForIn()== + bpEqKey "FOR" and (bpVariable() or bpTrap()) and (bpCompMissing "IN") + and ((bpSeg() or bpTrap()) and + (bpEqKey "BY" and (bpArith() or bpTrap()) and + bpPush bfForInBy(bpPop3(),bpPop2(),bpPop1())) or + bpPush bfForin(bpPop2(),bpPop1())) + +bpSeg()== + bpArith() and + (bpEqKey "SEG" and + (bpArith() and bpPush(bfSegment2(bpPop2(),bpPop1())) + or bpPush(bfSegment1(bpPop1()))) or true) + +bpIterator()== + bpForIn() or bpSuchThat() or bpWhile() or bpUntil() + +bpIteratorList()==bpOneOrMore function bpIterator + and bpPush bfIterators bpPop1 () + +bpCrossBackSet()== bpEqKey "CROSS" and (bpEqKey "BACKSET" or true) + +bpIterators()== + bpListofFun(function bpIteratorList, + function bpCrossBackSet,function bfCross) + +bpAssign()== + a:=bpState() + if bpStatement() + then + if bpEqPeek "BEC" + then + bpRestore a + bpAssignment() or bpTrap() + else true + else + bpRestore a + false + +bpAssignment()== + bpAssignVariable() and + bpEqKey "BEC" and + (bpAssign() or bpTrap()) and + bpPush bfAssign (bpPop2(),bpPop1()) + +-- should only be allowed in sequences +bpExit()== + bpAssign() and (bpEqKey "EXIT" and + ((bpWhere() or bpTrap()) and + bpPush bfExit (bpPop2(),bpPop1())) + or true) + +++ returns true if the next token introduces a definition. +bpBeginDefinition() == + bpEqPeek "DEF" or + $sawParenthesizedHead and bpEqPeek "COLON" + +bpDefinition()== + a:=bpState() + bpExit() => + bpBeginDefinition() => + bpRestore a + bpDef() + bpEqPeek "TDEF" => + bpRestore a + bpTypeAliasDefition() + bpEqPeek "MDEF" => + bpRestore a + bpMdef() + true + bpRestore a + false + +bpStoreName()== + $op := car $stack + $wheredefs := nil + $typings := nil + $returnType := true -- assume we may return anything + $bodyHasReturn := false + true + +bpReturnType() == + -- a return type is acceptable for a function definition only + -- if its parameters are written in round parenthesis. + -- In particular, we reject the situation `foo x:Integer == ...' + $sawParenthesizedHead and bpEqKey "COLON" => + bpApplication() or bpTrap() + $returnType := bpPop1() + true + true + +bpDef() == + bpName() and bpStoreName() and + bpDefTail() and bpPush bfCompDef bpPop1 () + +bpDDef() == bpName() and bpDefTail() + +++ Parse the remaining of a simple definition. +bpSimpleDefinitionTail() == + bpEqKey "DEF" and + (bpWhere() or bpTrap()) + and bpPush bfDefinition(bpPop2(),bfTuple nil, bpPop1()) + +++ Parse the remaining of a compound definition. +bpCompoundDefinitionTail() == + bpVariable() and bpReturnType() and + bpEqKey "DEF" and (bpWhere() or bpTrap()) + and bpPush bfDefinition(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() == + bpSimpleDefinitionTail() + or bpCompoundDefinitionTail() + + +bpMDefTail()== + -- bpEqKey "MDEF" and + -- (bpWhere() or bpTrap()) + -- and bpPush bfMDefinition1(bpPop2(),bpPop1()) + -- or + (bpVariable() or bpTrap()) and + bpEqKey "MDEF" and (bpWhere() or bpTrap()) + and bpPush bfMDefinition(bpPop3(),bpPop2(),bpPop1()) + +bpMdef()== bpName() and bpStoreName() and bpMDefTail() + +bpWhere()== + bpDefinition() and + (bpEqKey "WHERE" and (bpDefinitionItem() or bpTrap()) + and bpPush bfWhere(bpPop1(),bpPop1()) or true) + +bpDefinitionItem()== + a:=bpState() + if bpDDef() + then true + else + bpRestore a + if bpBDefinitionPileItems() + then true + else + bpRestore a + if bpPDefinitionItems() + then true + else + bpRestore a + bpWhere() + +bpDefinitionPileItems()== + bpListAndRecover function bpDefinitionItem + and bpPush bfDefSequence bpPop1() + +bpBDefinitionPileItems()== bpPileBracketed function bpDefinitionPileItems + +bpSemiColonDefinition()==bpSemiListing + (function bpDefinitionItem,function bfDefSequence) + +bpPDefinitionItems()==bpParenthesized function bpSemiColonDefinition + +bpComma()== + bpModule() or bpImport() or + bpTuple function bpWhere + +bpTuple(p)==bpListofFun(p,function bpCommaBackSet,function bfTuple) + +bpCommaBackSet()== bpEqKey "COMMA" and (bpEqKey "BACKSET" or true) + +bpSemiColon()==bpSemiListing (function bpComma,function bfSequence) + +bpSemiListing(p,f)==bpListofFun(p,function bpSemiBackSet,f) + +bpSemiBackSet()== bpEqKey "SEMICOLON" and (bpEqKey "BACKSET" or true) + +bpPDefinition()== bpIndentParenthesized function bpSemiColon + +bpPileItems()== + bpListAndRecover function bpSemiColon and bpPush bfSequence bpPop1() + +bpBPileDefinition()== bpPileBracketed function bpPileItems + +bpIteratorTail()== + (bpEqKey "REPEAT" or true) and bpIterators() + +--bpExpression()== bpLogical() + +bpConstruct()==bpBracket function bpConstruction + +bpConstruction()== + bpComma() and + (bpIteratorTail() and + bpPush bfCollect (bpPop2(),bpPop1()) or + bpPush bfTupleConstruct bpPop1()) + +bpDConstruct()==bpBracket function bpDConstruction + +bpDConstruction()== + bpComma() and + (bpIteratorTail() and + bpPush bfDCollect (bpPop2(),bpPop1()) or + bpPush bfDTuple bpPop1()) + + + +--PATTERN + +--bpNameOrDot() == bpName() or bpDot() or bpEqual() + +bpPattern()== bpBracketConstruct function bpPatternL + or bpName() or bpConstTok() + +bpEqual()== + bpEqKey "SHOEEQ" and (bpApplication() or bpConstTok() or + bpTrap()) and bpPush bfEqual bpPop1() + +bpRegularPatternItem() == + bpEqual() or + bpConstTok() or bpDot() or + bpName() and + ((bpEqKey "BEC" and (bpPattern() or bpTrap()) + and bpPush bfAssign(bpPop2(),bpPop1())) or true) + or bpBracketConstruct function bpPatternL + +bpRegularPatternItemL()== + bpRegularPatternItem() and bpPush [bpPop1()] + +bpRegularList()== + bpListof(function bpRegularPatternItemL,"COMMA",function bfAppend) + +bpPatternColon()== + bpEqKey "COLON" and (bpRegularPatternItem() or bpTrap()) + and bpPush [bfColon bpPop1()] + + +-- only one colon +bpPatternL() == bpPatternList() and bpPush bfTuple bpPop1() + +bpPatternList()== + if bpRegularPatternItemL() + then + while (bpEqKey "COMMA" and (bpRegularPatternItemL() or + (bpPatternTail() + and bpPush append(bpPop2(),bpPop1()) + or bpTrap();false) )) repeat + bpPush append(bpPop2(),bpPop1()) + true + else bpPatternTail() + +bpPatternTail()== + bpPatternColon() and + (bpEqKey "COMMA" and (bpRegularList() or bpTrap()) + and bpPush append (bpPop2(),bpPop1()) or true) + +-- BOUND VARIABLE +bpRegularBVItem() == + bpBVString() or + bpConstTok() or + (bpName() and + (bpEqKey "COLON" and (bpApplication() or bpTrap()) + and bpPush bfTagged(bpPop2(), bpPop1()) or + bpEqKey "BEC" and (bpPattern() or bpTrap()) + and bpPush bfAssign(bpPop2(),bpPop1()) or + (bpEqKey "IS" and (bpPattern() or bpTrap()) + and bpPush bfAssign(bpPop2(),bpPop1())) or true)) + or bpBracketConstruct function bpPatternL + +bpBVString()== + EQ(shoeTokType $stok,"STRING") and + bpPush(["BVQUOTE",INTERN $ttok]) and bpNext() + +bpRegularBVItemL() == + bpRegularBVItem() and bpPush [bpPop1()] + +bpColonName()== + bpEqKey "COLON" and (bpName() or bpBVString() or bpTrap()) + + +-- at most one colon at end +bpBoundVariablelist()== + if bpRegularBVItemL() + then + while (bpEqKey "COMMA" and (bpRegularBVItemL() or + (bpColonName() + and bpPush bfColonAppend(bpPop2(),bpPop1()) + or bpTrap();false) )) repeat + bpPush append(bpPop2(),bpPop1()) + true + else bpColonName() and bpPush bfColonAppend(nil,bpPop1()) + + +++ Mark the start of parameter list enclosed in round parenthesis +bpBeginParameterList() == + $sawParenthesizedHead := false + true + +++ Mark the end of parameter list enclosed in round parenthesis +bpEndParameterList() == + $sawParenthesizedHead := true + +bpVariable()== + bpBeginParameterList() and + bpParenthesized function bpBoundVariablelist and + bpPush bfTupleIf bpPop1() and bpEndParameterList() + or bpBracketConstruct function bpPatternL + or bpName() or bpConstTok() + +bpAssignVariable()== + bpBracketConstruct function bpPatternL or bpAssignLHS() + +bpAssignLHS()== + bpName() and (bpEqKey "COLON" and (bpApplication() or bpTrap()) + and bpPush bfLocal(bpPop2(),bpPop1()) + or bpEqKey "DOT" and bpList(function bpPrimary,"DOT", + function bfListOf) + and bpChecknull() and + bpPush bfTuple(cons(bpPop2(),bpPop1())) + or true) +bpChecknull()== + a:=bpPop1() + if null a + then bpTrap() + else bpPush a + +bpStruct()== + bpEqKey "STRUCTURE" and + (bpName() or bpTrap()) and + (bpEqKey "DEF" or bpTrap()) and + bpTypeList() and bpPush bfStruct(bpPop2(),bpPop1()) + +bpTypeList() == bpPileBracketed function bpTypeItemList + or bpTerm() and bpPush [bpPop1()] + +bpTypeItemList() == bpListAndRecover function bpTerm + +bpTerm() == + (bpName() or bpTrap()) and + ((bpParenthesized function bpIdList and + bpPush bfNameArgs (bpPop2(),bpPop1())) + or bpName() and bpPush bfNameArgs(bpPop2(),bpPop1())) + or bpPush(bfNameOnly bpPop1()) + +bpIdList()== bpTuple function bpName + +bpCase()== + bpEqKey "CASE" and + (bpWhere() or bpTrap()) and + (bpEqKey "OF" or bpMissing "OF") and + bpPiledCaseItems() + +bpPiledCaseItems()== + bpPileBracketed function bpCaseItemList and + bpPush bfCase(bpPop2(),bpPop1()) +bpCaseItemList()== + bpListAndRecover function bpCaseItem + +bpCaseItem()== + (bpTerm() or bpTrap()) and + (bpEqKey "EXIT" or bpTrap()) and + (bpWhere() or bpTrap()) and + bpPush bfCaseItem (bpPop2(),bpPop1()) + +@ + + +\section{The Common Lisp translation} +\label{sec:cl-translation} + +<<parser.clisp>>= +(EVAL-WHEN (:COMPILE-TOPLEVEL) (PROVIDE "boot-parser")) + +(IMPORT-MODULE "includer") + +(IMPORT-MODULE "scanner") + +(IMPORT-MODULE "ast") + +(IN-PACKAGE "BOOTTRAN") + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |$sawParenthesizedHead| NIL)) + +(EVAL-WHEN (:EXECUTE :LOAD-TOPLEVEL) + (DEFPARAMETER |$bodyHasReturn| NIL)) + +(DEFUN |bpFirstToken| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok| |$inputStream|)) + (RETURN + (PROGN + (SETQ |$stok| + (COND + ((NULL |$inputStream|) + (|shoeTokConstruct| 'ERROR 'NOMORE + (|shoeTokPosn| |$stok|))) + ('T (CAR |$inputStream|)))) + (SETQ |$ttok| (|shoeTokPart| |$stok|)) + T)))) + +(DEFUN |bpFirstTok| () + (PROG () + (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$ttok| |$stok| + |$inputStream|)) + (RETURN + (PROGN + (SETQ |$stok| + (COND + ((NULL |$inputStream|) + (|shoeTokConstruct| 'ERROR 'NOMORE + (|shoeTokPosn| |$stok|))) + ('T (CAR |$inputStream|)))) + (SETQ |$ttok| (|shoeTokPart| |$stok|)) + (COND + ((AND (< 0 |$bpParenCount|) (EQCAR |$stok| 'KEY)) + (COND + ((EQ |$ttok| 'SETTAB) + (PROGN (SETQ |$bpCount| (+ |$bpCount| 1)) (|bpNext|))) + ((EQ |$ttok| 'BACKTAB) + (PROGN (SETQ |$bpCount| (- |$bpCount| 1)) (|bpNext|))) + ((EQ |$ttok| 'BACKSET) (|bpNext|)) + (#0='T T))) + (#0# T)))))) + +(DEFUN |bpNext| () + (PROG () + (DECLARE (SPECIAL |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| (CDR |$inputStream|)) + (|bpFirstTok|))))) + +(DEFUN |bpNextToken| () + (PROG () + (DECLARE (SPECIAL |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| (CDR |$inputStream|)) + (|bpFirstToken|))))) + +(DEFUN |bpState| () + (PROG () + (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| + |$inputStream|)) + (RETURN (LIST |$inputStream| |$stack| |$bpParenCount| |$bpCount|)))) + +(DEFUN |bpRestore| (|x|) + (PROG () + (DECLARE (SPECIAL |$bpCount| |$bpParenCount| |$stack| + |$inputStream|)) + (RETURN + (PROGN + (SETQ |$inputStream| (CAR |x|)) + (|bpFirstToken|) + (SETQ |$stack| (CADR |x|)) + (SETQ |$bpParenCount| (CADDR |x|)) + (SETQ |$bpCount| (CADDDR |x|)) + T)))) + +(DEFUN |bpPush| (|x|) + (PROG () + (DECLARE (SPECIAL |$stack|)) + (RETURN (SETQ |$stack| (CONS |x| |$stack|))))) + +(DEFUN |bpPushId| () + (PROG () + (DECLARE (SPECIAL |$stack| |$ttok|)) + (RETURN (SETQ |$stack| (CONS (|bfReName| |$ttok|) |$stack|))))) + +(DEFUN |bpPop1| () + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (PROGN + (SETQ |a| (CAR |$stack|)) + (SETQ |$stack| (CDR |$stack|)) + |a|)))) + +(DEFUN |bpPop2| () + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (PROGN + (SETQ |a| (CADR |$stack|)) + (RPLACD |$stack| (CDDR |$stack|)) + |a|)))) + +(DEFUN |bpPop3| () + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (PROGN + (SETQ |a| (CADDR |$stack|)) + (RPLACD (CDR |$stack|) (CDDDR |$stack|)) + |a|)))) + +(DEFUN |bpIndentParenthesized| (|f|) + (PROG (|$bpCount| |a|) + (DECLARE (SPECIAL |$inputStream| |$bpCount| |$bpParenCount| + |$stok|)) + (RETURN + (PROGN + (SETQ |$bpCount| 0) + (SETQ |a| |$stok|) + (COND + ((|bpEqPeek| 'OPAREN) + (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) (|bpNext|) + (COND + ((AND (APPLY |f| NIL) (|bpFirstTok|) + (OR (|bpEqPeek| 'CPAREN) (|bpParenTrap| |a|))) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) + (|bpNextToken|) + (COND + ((EQL |$bpCount| 0) T) + (#0='T + (PROGN + (SETQ |$inputStream| + (APPEND (|bpAddTokens| |$bpCount|) + |$inputStream|)) + (|bpFirstToken|) + (COND + ((EQL |$bpParenCount| 0) (PROGN (|bpCancel|) T)) + (#0# T)))))) + ((|bpEqPeek| 'CPAREN) (|bpPush| (|bfTuple| NIL)) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) + (|bpNextToken|) T) + (#1='T (|bpParenTrap| |a|)))) + (#1# NIL)))))) + +(DEFUN |bpParenthesized| (|f|) + (PROG (|a|) + (DECLARE (SPECIAL |$stok|)) + (RETURN + (PROGN + (SETQ |a| |$stok|) + (COND + ((|bpEqKey| 'OPAREN) + (COND + ((AND (APPLY |f| NIL) + (OR (|bpEqKey| 'CPAREN) (|bpParenTrap| |a|))) + T) + ((|bpEqKey| 'CPAREN) (|bpPush| (|bfTuple| NIL)) T) + (#0='T (|bpParenTrap| |a|)))) + (#0# NIL)))))) + +(DEFUN |bpBracket| (|f|) + (PROG (|a|) + (DECLARE (SPECIAL |$stok|)) + (RETURN + (PROGN + (SETQ |a| |$stok|) + (COND + ((|bpEqKey| 'OBRACK) + (COND + ((AND (APPLY |f| NIL) + (OR (|bpEqKey| 'CBRACK) (|bpBrackTrap| |a|))) + (|bpPush| (|bfBracket| (|bpPop1|)))) + ((|bpEqKey| 'CBRACK) (|bpPush| NIL)) + (#0='T (|bpBrackTrap| |a|)))) + (#0# NIL)))))) + +(DEFUN |bpPileBracketed| (|f|) + (PROG () + (RETURN + (COND + ((|bpEqKey| 'SETTAB) + (COND + ((|bpEqKey| 'BACKTAB) T) + ((AND (APPLY |f| NIL) + (OR (|bpEqKey| 'BACKTAB) (|bpPileTrap|))) + (|bpPush| (|bfPile| (|bpPop1|)))) + (#0='T NIL))) + (#0# NIL))))) + +(DEFUN |bpListof| (|f| |str1| |g|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (COND + ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|))) + (SETQ |a| |$stack|) (SETQ |$stack| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpEqKey| |str1|) + (OR (APPLY |f| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T 0))))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| + (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) + (#0='T T))) + (#0# NIL))))) + +(DEFUN |bpListofFun| (|f| |h| |g|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (COND + ((AND (APPLY |h| NIL) (OR (APPLY |f| NIL) (|bpTrap|))) + (SETQ |a| |$stack|) (SETQ |$stack| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (APPLY |h| NIL) + (OR (APPLY |f| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T 0))))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| + (|bfListOf| + (CONS (|bpPop3|) + (CONS (|bpPop2|) (|bpPop1|))))))) + (#0='T T))) + (#0# NIL))))) + +(DEFUN |bpList| (|f| |str1| |g|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (COND + ((AND (|bpEqKey| |str1|) (OR (APPLY |f| NIL) (|bpTrap|))) + (SETQ |a| |$stack|) (SETQ |$stack| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpEqKey| |str1|) + (OR (APPLY |f| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T 0))))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| + (FUNCALL |g| + (CONS (|bpPop3|) (CONS (|bpPop2|) (|bpPop1|)))))) + (#0='T (|bpPush| (FUNCALL |g| (LIST (|bpPop1|))))))) + (#0# (|bpPush| (FUNCALL |g| NIL))))))) + +(DEFUN |bpOneOrMore| (|f|) + (PROG (|a|) + (DECLARE (SPECIAL |$stack|)) + (RETURN + (COND + ((APPLY |f| NIL) + (PROGN + (SETQ |a| |$stack|) + (SETQ |$stack| NIL) + ((LAMBDA () + (LOOP + (COND ((NOT (APPLY |f| NIL)) (RETURN NIL)) ('T 0))))) + (SETQ |$stack| (CONS (NREVERSE |$stack|) |a|)) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|))))) + ('T NIL))))) + +(DEFUN |bpAnyNo| (|s|) + (PROG () + (RETURN + (PROGN + ((LAMBDA () + (LOOP (COND ((NOT (APPLY |s| NIL)) (RETURN NIL)) ('T 0))))) + T)))) + +(DEFUN |bpAndOr| (|keyword| |p| |f|) + (PROG () + (RETURN + (AND (|bpEqKey| |keyword|) (OR (APPLY |p| NIL) (|bpTrap|)) + (|bpPush| (FUNCALL |f| (|bpPop1|))))))) + +(DEFUN |bpConditional| (|f|) + (PROG () + (RETURN + (COND + ((AND (|bpEqKey| 'IF) (OR (|bpWhere|) (|bpTrap|)) + (OR (|bpEqKey| 'BACKSET) T)) + (COND + ((|bpEqKey| 'SETTAB) + (COND + ((|bpEqKey| 'THEN) + (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|) + (|bpEqKey| 'BACKTAB))) + (#0='T (|bpMissing| 'THEN)))) + ((|bpEqKey| 'THEN) + (AND (OR (APPLY |f| NIL) (|bpTrap|)) (|bpElse| |f|))) + (#0# (|bpMissing| '|then|)))) + (#0# NIL))))) + +(DEFUN |bpElse| (|f|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpBacksetElse|) + (AND (OR (APPLY |f| NIL) (|bpTrap|)) + (|bpPush| (|bfIf| (|bpPop3|) (|bpPop2|) (|bpPop1|))))) + ('T (|bpRestore| |a|) + (|bpPush| (|bfIfThenOnly| (|bpPop2|) (|bpPop1|))))))))) + +(DEFUN |bpBacksetElse| () + (PROG () + (RETURN + (COND + ((|bpEqKey| 'BACKSET) (|bpEqKey| 'ELSE)) + ('T (|bpEqKey| 'ELSE)))))) + +(DEFUN |bpEqPeek| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|))))) + +(DEFUN |bpEqKey| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|) (|bpNext|))))) + +(DEFUN |bpEqKeyNextTok| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (EQ |s| |$ttok|) (|bpNextToken|))))) + +(DEFUN |bpPileTrap| () (PROG () (RETURN (|bpMissing| 'BACKTAB)))) + +(DEFUN |bpBrackTrap| (|x|) + (PROG () (RETURN (|bpMissingMate| '] |x|)))) + +(DEFUN |bpParenTrap| (|x|) + (PROG () (RETURN (|bpMissingMate| '|)| |x|)))) + +(DEFUN |bpMissingMate| (|close| |open|) + (PROG () + (RETURN + (PROGN + (|bpSpecificErrorAtToken| |open| "possibly missing mate") + (|bpMissing| |close|))))) + +(DEFUN |bpMissing| (|s|) + (PROG () + (RETURN + (PROGN + (|bpSpecificErrorHere| + (CONCAT (PNAME |s|) " possibly missing")) + (THROW 'TRAPPOINT 'TRAPPED))))) + +(DEFUN |bpCompMissing| (|s|) + (PROG () (RETURN (OR (|bpEqKey| |s|) (|bpMissing| |s|))))) + +(DEFUN |bpTrap| () + (PROG () + (RETURN + (PROGN (|bpGeneralErrorHere|) (THROW 'TRAPPOINT 'TRAPPED))))) + +(DEFUN |bpRecoverTrap| () + (PROG (|pos2| |pos1|) + (DECLARE (SPECIAL |$stok|)) + (RETURN + (PROGN + (|bpFirstToken|) + (SETQ |pos1| (|shoeTokPosn| |$stok|)) + (|bpMoveTo| 0) + (SETQ |pos2| (|shoeTokPosn| |$stok|)) + (|bpIgnoredFromTo| |pos1| |pos2|) + (|bpPush| (LIST (LIST "pile syntax error"))))))) + +(DEFUN |bpListAndRecover| (|f|) + (PROG (|found| |c| |done| |b| |a|) + (DECLARE (SPECIAL |$inputStream| |$stack|)) + (RETURN + (PROGN + (SETQ |a| |$stack|) + (SETQ |b| NIL) + (SETQ |$stack| NIL) + (SETQ |done| NIL) + (SETQ |c| |$inputStream|) + ((LAMBDA () + (LOOP + (COND + (|done| (RETURN NIL)) + ('T + (PROGN + (SETQ |found| (CATCH 'TRAPPOINT (APPLY |f| NIL))) + (COND + ((EQ |found| 'TRAPPED) (SETQ |$inputStream| |c|) + (|bpRecoverTrap|)) + ((NULL |found|) (SETQ |$inputStream| |c|) + (|bpGeneralErrorHere|) (|bpRecoverTrap|))) + (COND + ((|bpEqKey| 'BACKSET) (SETQ |c| |$inputStream|)) + ((OR (|bpEqPeek| 'BACKTAB) (NULL |$inputStream|)) + (SETQ |done| T)) + (#0='T (SETQ |$inputStream| |c|) + (|bpGeneralErrorHere|) (|bpRecoverTrap|) + (COND + ((OR (|bpEqPeek| 'BACKTAB) + (NULL |$inputStream|)) + (SETQ |done| T)) + (#0# (|bpNext|) (SETQ |c| |$inputStream|))))) + (SETQ |b| (CONS (|bpPop1|) |b|)))))))) + (SETQ |$stack| |a|) + (|bpPush| (NREVERSE |b|)))))) + +(DEFUN |bpMoveTo| (|n|) + (PROG () + (DECLARE (SPECIAL |$bpParenCount| |$bpCount| |$inputStream|)) + (RETURN + (COND + ((NULL |$inputStream|) T) + ((|bpEqPeek| 'BACKTAB) + (COND + ((EQL |n| 0) T) + (#0='T + (PROGN + (|bpNextToken|) + (SETQ |$bpCount| (- |$bpCount| 1)) + (|bpMoveTo| (- |n| 1)))))) + ((|bpEqPeek| 'BACKSET) + (COND + ((EQL |n| 0) T) + (#0# (PROGN (|bpNextToken|) (|bpMoveTo| |n|))))) + ((|bpEqPeek| 'SETTAB) + (PROGN (|bpNextToken|) (|bpMoveTo| (+ |n| 1)))) + ((|bpEqPeek| 'OPAREN) + (PROGN + (|bpNextToken|) + (SETQ |$bpParenCount| (+ |$bpParenCount| 1)) + (|bpMoveTo| |n|))) + ((|bpEqPeek| 'CPAREN) + (PROGN + (|bpNextToken|) + (SETQ |$bpParenCount| (- |$bpParenCount| 1)) + (|bpMoveTo| |n|))) + (#0# (PROGN (|bpNextToken|) (|bpMoveTo| |n|))))))) + +(DEFUN |bpQualifiedName| () + (PROG () + (DECLARE (SPECIAL |$stok|)) + (RETURN + (COND + ((|bpEqPeek| 'COLON-COLON) + (PROGN + (|bpNext|) + (AND (EQCAR |$stok| 'ID) (|bpPushId|) (|bpNext|) + (|bpPush| (|bfColonColon| (|bpPop2|) (|bpPop1|)))))) + ('T NIL))))) + +(DEFUN |bpName| () + (PROG () + (DECLARE (SPECIAL |$stok|)) + (RETURN + (COND + ((EQCAR |$stok| 'ID) + (PROGN + (|bpPushId|) + (|bpNext|) + (|bpAnyNo| #'|bpQualifiedName|))) + ('T NIL))))) + +(DEFUN |bpConstTok| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (COND + ((MEMQ (|shoeTokType| |$stok|) '(INTEGER FLOAT)) + (PROGN (|bpPush| |$ttok|) (|bpNext|))) + ((EQCAR |$stok| 'LISP) + (AND (|bpPush| (|bfReadLisp| |$ttok|)) (|bpNext|))) + ((EQCAR |$stok| 'LISPEXP) (AND (|bpPush| |$ttok|) (|bpNext|))) + ((EQCAR |$stok| 'LINE) + (AND (|bpPush| (LIST '+LINE |$ttok|)) (|bpNext|))) + ((|bpEqPeek| 'QUOTE) + (PROGN + (|bpNext|) + (AND (OR (|bpSexp|) (|bpTrap|)) + (|bpPush| (|bfSymbol| (|bpPop1|)))))) + ('T (|bpString|)))))) + +(DEFUN |bpModule| () + (PROG () + (RETURN + (COND + ((|bpEqKey| 'MODULE) + (AND (|bpConstTok|) (|bpPush| (|Module| (|bpPop1|))))) + ('T NIL))))) + +(DEFUN |bpImport| () + (PROG () + (RETURN + (COND + ((|bpEqKey| 'IMPORT) + (AND (|bpConstTok|) (|bpPush| (|Import| (|bpPop1|))))) + ('T NIL))))) + +(DEFUN |bpTypeAliasDefition| () + (PROG () + (RETURN + (AND (OR (|bpName|) (|bpTrap|)) (|bpEqKey| 'TDEF) (|bpLogical|) + (|bpPush| (|TypeAlias| (|bpPop2|) NIL (|bpPop1|))))))) + +(DEFUN |bpCancel| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpEqKeyNextTok| 'SETTAB) + (COND + ((|bpCancel|) + (COND + ((|bpEqKeyNextTok| 'BACKTAB) T) + (#0='T (|bpRestore| |a|) NIL))) + ((|bpEqKeyNextTok| 'BACKTAB) T) + (#0# (|bpRestore| |a|) NIL))) + (#0# NIL)))))) + +(DEFUN |bpAddTokens| (|n|) + (PROG () + (DECLARE (SPECIAL |$stok|)) + (RETURN + (COND + ((EQL |n| 0) NIL) + ((< 0 |n|) + (CONS (|shoeTokConstruct| 'KEY 'SETTAB + (|shoeTokPosn| |$stok|)) + (|bpAddTokens| (- |n| 1)))) + ('T + (CONS (|shoeTokConstruct| 'KEY 'BACKTAB + (|shoeTokPosn| |$stok|)) + (|bpAddTokens| (+ |n| 1)))))))) + +(DEFUN |bpExceptions| () + (PROG () + (RETURN + (OR (|bpEqPeek| 'DOT) (|bpEqPeek| 'QUOTE) (|bpEqPeek| 'OPAREN) + (|bpEqPeek| 'CPAREN) (|bpEqPeek| 'SETTAB) + (|bpEqPeek| 'BACKTAB) (|bpEqPeek| 'BACKSET))))) + +(DEFUN |bpSexpKey| () + (PROG (|a|) + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (COND + ((AND (EQCAR |$stok| 'KEY) (NULL (|bpExceptions|))) + (PROGN + (SETQ |a| (GET |$ttok| 'SHOEINF)) + (COND + ((NULL |a|) (AND (|bpPush| |$ttok|) (|bpNext|))) + (#0='T (AND (|bpPush| |a|) (|bpNext|)))))) + (#0# NIL))))) + +(DEFUN |bpAnyId| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (OR (AND (|bpEqKey| 'MINUS) + (OR (EQCAR |$stok| 'INTEGER) (|bpTrap|)) + (|bpPush| (- |$ttok|)) (|bpNext|)) + (|bpSexpKey|) + (AND (MEMQ (|shoeTokType| |$stok|) + '(ID INTEGER STRING FLOAT)) + (|bpPush| |$ttok|) (|bpNext|)))))) + +(DEFUN |bpSexp| () + (PROG () + (RETURN + (OR (|bpAnyId|) + (AND (|bpEqKey| 'QUOTE) (OR (|bpSexp|) (|bpTrap|)) + (|bpPush| (|bfSymbol| (|bpPop1|)))) + (|bpIndentParenthesized| #'|bpSexp1|))))) + +(DEFUN |bpSexp1| () + (PROG () + (RETURN + (OR (AND (|bpFirstTok|) (|bpSexp|) + (OR (AND (|bpEqKey| 'DOT) (|bpSexp|) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))) + (AND (|bpSexp1|) + (|bpPush| (CONS (|bpPop2|) (|bpPop1|)))))) + (|bpPush| NIL))))) + +(DEFUN |bpPrimary1| () + (PROG () + (RETURN + (OR (|bpName|) (|bpDot|) (|bpConstTok|) (|bpConstruct|) + (|bpCase|) (|bpStruct|) (|bpPDefinition|) + (|bpBPileDefinition|))))) + +(DEFUN |bpPrimary| () + (PROG () + (RETURN + (AND (|bpFirstTok|) (OR (|bpPrimary1|) (|bpPrefixOperator|)))))) + +(DEFUN |bpDot| () + (PROG () (RETURN (AND (|bpEqKey| 'DOT) (|bpPush| (|bfDot|)))))) + +(DEFUN |bpPrefixOperator| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (GET |$ttok| 'SHOEPRE) (|bpPushId|) + (|bpNext|))))) + +(DEFUN |bpInfixOperator| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (GET |$ttok| 'SHOEINF) (|bpPushId|) + (|bpNext|))))) + +(DEFUN |bpSelector| () + (PROG () + (RETURN + (AND (|bpEqKey| 'DOT) + (OR (AND (|bpPrimary|) + (|bpPush| (|bfElt| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfSuffixDot| (|bpPop1|)))))))) + +(DEFUN |bpOperator| () + (PROG () (RETURN (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|))))) + +(DEFUN |bpApplication| () + (PROG () + (RETURN + (AND (|bpPrimary|) (|bpAnyNo| #'|bpSelector|) + (OR (AND (|bpApplication|) + (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpTagged| () + (PROG () + (RETURN + (AND (|bpApplication|) + (OR (AND (|bpEqKey| 'COLON) + (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpExpt| () + (PROG () (RETURN (|bpRightAssoc| '(POWER) #'|bpTagged|)))) + +(DEFUN |bpInfKey| (|s|) + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQCAR |$stok| 'KEY) (MEMBER |$ttok| |s|) (|bpPushId|) + (|bpNext|))))) + +(DEFUN |bpInfGeneric| (|s|) + (PROG () + (RETURN (AND (|bpInfKey| |s|) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpRightAssoc| (|o| |p|) + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((APPLY |p| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpInfGeneric| |o|) + (OR (|bpRightAssoc| |o| |p|) (|bpTrap|)))) + (RETURN NIL)) + ('T + (|bpPush| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))))))) + T) + ('T (|bpRestore| |a|) NIL)))))) + +(DEFUN |bpLeftAssoc| (|operations| |parser|) + (PROG () + (RETURN + (COND + ((APPLY |parser| NIL) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpInfGeneric| |operations|) + (OR (APPLY |parser| NIL) (|bpTrap|)))) + (RETURN NIL)) + ('T + (|bpPush| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))))))) + T) + ('T NIL))))) + +(DEFUN |bpString| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQ (|shoeTokType| |$stok|) 'STRING) + (|bpPush| (LIST 'QUOTE (INTERN |$ttok|))) (|bpNext|))))) + +(DEFUN |bpThetaName| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (COND + ((AND (EQCAR |$stok| 'ID) (GET |$ttok| 'SHOETHETA)) + (|bpPushId|) (|bpNext|)) + ('T NIL))))) + +(DEFUN |bpReduceOperator| () + (PROG () + (RETURN (OR (|bpInfixOperator|) (|bpString|) (|bpThetaName|))))) + +(DEFUN |bpReduce| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((AND (|bpReduceOperator|) (|bpEqKey| 'SLASH)) + (COND + ((|bpEqPeek| 'OBRACK) + (AND (OR (|bpDConstruct|) (|bpTrap|)) + (|bpPush| (|bfReduceCollect| (|bpPop2|) (|bpPop1|))))) + ('T + (AND (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfReduce| (|bpPop2|) (|bpPop1|))))))) + ('T (|bpRestore| |a|) NIL)))))) + +(DEFUN |bpTimes| () + (PROG () + (RETURN + (OR (|bpReduce|) (|bpLeftAssoc| '(TIMES SLASH) #'|bpExpt|))))) + +(DEFUN |bpMinus| () + (PROG () + (RETURN + (OR (AND (|bpInfGeneric| '(MINUS)) (OR (|bpTimes|) (|bpTrap|)) + (|bpPush| (|bfApplication| (|bpPop2|) (|bpPop1|)))) + (|bpTimes|))))) + +(DEFUN |bpArith| () + (PROG () (RETURN (|bpLeftAssoc| '(PLUS MINUS) #'|bpMinus|)))) + +(DEFUN |bpIs| () + (PROG () + (RETURN + (AND (|bpArith|) + (OR (AND (|bpInfKey| '(IS ISNT)) + (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| + (|bfISApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))) + T))))) + +(DEFUN |bpBracketConstruct| (|f|) + (PROG () + (RETURN + (AND (|bpBracket| |f|) (|bpPush| (|bfConstruct| (|bpPop1|))))))) + +(DEFUN |bpCompare| () + (PROG () + (RETURN + (AND (|bpIs|) + (OR (AND (|bpInfKey| '(SHOEEQ NE LT LE GT GE IN)) + (OR (|bpIs|) (|bpTrap|)) + (|bpPush| + (|bfInfApplication| (|bpPop2|) (|bpPop2|) + (|bpPop1|)))) + T))))) + +(DEFUN |bpAnd| () + (PROG () (RETURN (|bpLeftAssoc| '(AND) #'|bpCompare|)))) + +(DEFUN |bpNoteReturnStmt| () + (PROG () + (DECLARE (SPECIAL |$bodyHasReturn|)) + (RETURN (PROGN (SETQ |$bodyHasReturn| T) T)))) + +(DEFUN |bpReturn| () + (PROG () + (RETURN + (OR (AND (|bpEqKey| 'RETURN) (|bpNoteReturnStmt|) + (OR (|bpAnd|) (|bpTrap|)) + (|bpPush| (|bfReturnNoName| (|bpPop1|)))) + (|bpAnd|))))) + +(DEFUN |bpLogical| () + (PROG () (RETURN (|bpLeftAssoc| '(OR) #'|bpReturn|)))) + +(DEFUN |bpExpression| () + (PROG () + (RETURN + (OR (AND (|bpEqKey| 'COLON) + (OR (AND (|bpLogical|) + (|bpPush| (|bfApplication| 'COLON (|bpPop1|)))) + (|bpTrap|))) + (|bpLogical|))))) + +(DEFUN |bpStatement| () + (PROG () + (RETURN + (OR (|bpConditional| #'|bpWhere|) (|bpLoop|) (|bpExpression|))))) + +(DEFUN |bpLoop| () + (PROG () + (RETURN + (OR (AND (|bpIterators|) (|bpCompMissing| 'REPEAT) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfLp| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'REPEAT) (OR (|bpLogical|) (|bpTrap|)) + (|bpPush| (|bfLoop1| (|bpPop1|)))))))) + +(DEFUN |bpSuchThat| () + (PROG () (RETURN (|bpAndOr| 'BAR #'|bpWhere| #'|bfSuchthat|)))) + +(DEFUN |bpWhile| () + (PROG () (RETURN (|bpAndOr| 'WHILE #'|bpLogical| #'|bfWhile|)))) + +(DEFUN |bpUntil| () + (PROG () (RETURN (|bpAndOr| 'UNTIL #'|bpLogical| #'|bfUntil|)))) + +(DEFUN |bpForIn| () + (PROG () + (RETURN + (AND (|bpEqKey| 'FOR) (OR (|bpVariable|) (|bpTrap|)) + (|bpCompMissing| 'IN) + (OR (AND (OR (|bpSeg|) (|bpTrap|)) (|bpEqKey| 'BY) + (OR (|bpArith|) (|bpTrap|)) + (|bpPush| + (|bfForInBy| (|bpPop3|) (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfForin| (|bpPop2|) (|bpPop1|)))))))) + +(DEFUN |bpSeg| () + (PROG () + (RETURN + (AND (|bpArith|) + (OR (AND (|bpEqKey| 'SEG) + (OR (AND (|bpArith|) + (|bpPush| + (|bfSegment2| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfSegment1| (|bpPop1|))))) + T))))) + +(DEFUN |bpIterator| () + (PROG () + (RETURN (OR (|bpForIn|) (|bpSuchThat|) (|bpWhile|) (|bpUntil|))))) + +(DEFUN |bpIteratorList| () + (PROG () + (RETURN + (AND (|bpOneOrMore| #'|bpIterator|) + (|bpPush| (|bfIterators| (|bpPop1|))))))) + +(DEFUN |bpCrossBackSet| () + (PROG () + (RETURN (AND (|bpEqKey| 'CROSS) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpIterators| () + (PROG () + (RETURN + (|bpListofFun| #'|bpIteratorList| #'|bpCrossBackSet| #'|bfCross|)))) + +(DEFUN |bpAssign| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpStatement|) + (COND + ((|bpEqPeek| 'BEC) (|bpRestore| |a|) + (OR (|bpAssignment|) (|bpTrap|))) + (#0='T T))) + (#0# (|bpRestore| |a|) NIL)))))) + +(DEFUN |bpAssignment| () + (PROG () + (RETURN + (AND (|bpAssignVariable|) (|bpEqKey| 'BEC) + (OR (|bpAssign|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpExit| () + (PROG () + (RETURN + (AND (|bpAssign|) + (OR (AND (|bpEqKey| 'EXIT) (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfExit| (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpBeginDefinition| () + (PROG () + (DECLARE (SPECIAL |$sawParenthesizedHead|)) + (RETURN + (OR (|bpEqPeek| 'DEF) + (AND |$sawParenthesizedHead| (|bpEqPeek| 'COLON)))))) + +(DEFUN |bpDefinition| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpExit|) + (COND + ((|bpBeginDefinition|) + (PROGN (|bpRestore| |a|) (|bpDef|))) + ((|bpEqPeek| 'TDEF) + (PROGN (|bpRestore| |a|) (|bpTypeAliasDefition|))) + ((|bpEqPeek| 'MDEF) (PROGN (|bpRestore| |a|) (|bpMdef|))) + (#0='T T))) + (#0# (PROGN (|bpRestore| |a|) NIL))))))) + +(DEFUN |bpStoreName| () + (PROG () + (DECLARE (SPECIAL |$bodyHasReturn| |$returnType| |$typings| + |$wheredefs| |$op| |$stack|)) + (RETURN + (PROGN + (SETQ |$op| (CAR |$stack|)) + (SETQ |$wheredefs| NIL) + (SETQ |$typings| NIL) + (SETQ |$returnType| T) + (SETQ |$bodyHasReturn| NIL) + T)))) + +(DEFUN |bpReturnType| () + (PROG () + (DECLARE (SPECIAL |$returnType| |$sawParenthesizedHead|)) + (RETURN + (COND + ((AND |$sawParenthesizedHead| (|bpEqKey| 'COLON)) + (PROGN + (OR (|bpApplication|) (|bpTrap|)) + (SETQ |$returnType| (|bpPop1|)) + T)) + ('T T))))) + +(DEFUN |bpDef| () + (PROG () + (RETURN + (AND (|bpName|) (|bpStoreName|) (|bpDefTail|) + (|bpPush| (|bfCompDef| (|bpPop1|))))))) + +(DEFUN |bpDDef| () (PROG () (RETURN (AND (|bpName|) (|bpDefTail|))))) + +(DEFUN |bpSimpleDefinitionTail| () + (PROG () + (RETURN + (AND (|bpEqKey| 'DEF) (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| + (|bfDefinition| (|bpPop2|) (|bfTuple| NIL) (|bpPop1|))))))) + +(DEFUN |bpCompoundDefinitionTail| () + (PROG () + (RETURN + (AND (|bpVariable|) (|bpReturnType|) (|bpEqKey| 'DEF) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfDefinition| (|bpPop3|) (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpDefTail| () + (PROG () + (RETURN + (OR (|bpSimpleDefinitionTail|) (|bpCompoundDefinitionTail|))))) + +(DEFUN |bpMDefTail| () + (PROG () + (RETURN + (AND (OR (|bpVariable|) (|bpTrap|)) (|bpEqKey| 'MDEF) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| + (|bfMDefinition| (|bpPop3|) (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpMdef| () + (PROG () (RETURN (AND (|bpName|) (|bpStoreName|) (|bpMDefTail|))))) + +(DEFUN |bpWhere| () + (PROG () + (RETURN + (AND (|bpDefinition|) + (OR (AND (|bpEqKey| 'WHERE) + (OR (|bpDefinitionItem|) (|bpTrap|)) + (|bpPush| (|bfWhere| (|bpPop1|) (|bpPop1|)))) + T))))) + +(DEFUN |bpDefinitionItem| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpState|)) + (COND + ((|bpDDef|) T) + (#0='T (|bpRestore| |a|) + (COND + ((|bpBDefinitionPileItems|) T) + (#0# (|bpRestore| |a|) + (COND + ((|bpPDefinitionItems|) T) + (#0# (|bpRestore| |a|) (|bpWhere|))))))))))) + +(DEFUN |bpDefinitionPileItems| () + (PROG () + (RETURN + (AND (|bpListAndRecover| #'|bpDefinitionItem|) + (|bpPush| (|bfDefSequence| (|bpPop1|))))))) + +(DEFUN |bpBDefinitionPileItems| () + (PROG () (RETURN (|bpPileBracketed| #'|bpDefinitionPileItems|)))) + +(DEFUN |bpSemiColonDefinition| () + (PROG () + (RETURN (|bpSemiListing| #'|bpDefinitionItem| #'|bfDefSequence|)))) + +(DEFUN |bpPDefinitionItems| () + (PROG () (RETURN (|bpParenthesized| #'|bpSemiColonDefinition|)))) + +(DEFUN |bpComma| () + (PROG () + (RETURN (OR (|bpModule|) (|bpImport|) (|bpTuple| #'|bpWhere|))))) + +(DEFUN |bpTuple| (|p|) + (PROG () + (RETURN (|bpListofFun| |p| #'|bpCommaBackSet| #'|bfTuple|)))) + +(DEFUN |bpCommaBackSet| () + (PROG () + (RETURN (AND (|bpEqKey| 'COMMA) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpSemiColon| () + (PROG () (RETURN (|bpSemiListing| #'|bpComma| #'|bfSequence|)))) + +(DEFUN |bpSemiListing| (|p| |f|) + (PROG () (RETURN (|bpListofFun| |p| #'|bpSemiBackSet| |f|)))) + +(DEFUN |bpSemiBackSet| () + (PROG () + (RETURN (AND (|bpEqKey| 'SEMICOLON) (OR (|bpEqKey| 'BACKSET) T))))) + +(DEFUN |bpPDefinition| () + (PROG () (RETURN (|bpIndentParenthesized| #'|bpSemiColon|)))) + +(DEFUN |bpPileItems| () + (PROG () + (RETURN + (AND (|bpListAndRecover| #'|bpSemiColon|) + (|bpPush| (|bfSequence| (|bpPop1|))))))) + +(DEFUN |bpBPileDefinition| () + (PROG () (RETURN (|bpPileBracketed| #'|bpPileItems|)))) + +(DEFUN |bpIteratorTail| () + (PROG () (RETURN (AND (OR (|bpEqKey| 'REPEAT) T) (|bpIterators|))))) + +(DEFUN |bpConstruct| () + (PROG () (RETURN (|bpBracket| #'|bpConstruction|)))) + +(DEFUN |bpConstruction| () + (PROG () + (RETURN + (AND (|bpComma|) + (OR (AND (|bpIteratorTail|) + (|bpPush| (|bfCollect| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfTupleConstruct| (|bpPop1|)))))))) + +(DEFUN |bpDConstruct| () + (PROG () (RETURN (|bpBracket| #'|bpDConstruction|)))) + +(DEFUN |bpDConstruction| () + (PROG () + (RETURN + (AND (|bpComma|) + (OR (AND (|bpIteratorTail|) + (|bpPush| (|bfDCollect| (|bpPop2|) (|bpPop1|)))) + (|bpPush| (|bfDTuple| (|bpPop1|)))))))) + +(DEFUN |bpPattern| () + (PROG () + (RETURN + (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) + (|bpConstTok|))))) + +(DEFUN |bpEqual| () + (PROG () + (RETURN + (AND (|bpEqKey| 'SHOEEQ) + (OR (|bpApplication|) (|bpConstTok|) (|bpTrap|)) + (|bpPush| (|bfEqual| (|bpPop1|))))))) + +(DEFUN |bpRegularPatternItem| () + (PROG () + (RETURN + (OR (|bpEqual|) (|bpConstTok|) (|bpDot|) + (AND (|bpName|) + (OR (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + T)) + (|bpBracketConstruct| #'|bpPatternL|))))) + +(DEFUN |bpRegularPatternItemL| () + (PROG () + (RETURN + (AND (|bpRegularPatternItem|) (|bpPush| (LIST (|bpPop1|))))))) + +(DEFUN |bpRegularList| () + (PROG () + (RETURN + (|bpListof| #'|bpRegularPatternItemL| 'COMMA #'|bfAppend|)))) + +(DEFUN |bpPatternColon| () + (PROG () + (RETURN + (AND (|bpEqKey| 'COLON) (OR (|bpRegularPatternItem|) (|bpTrap|)) + (|bpPush| (LIST (|bfColon| (|bpPop1|)))))))) + +(DEFUN |bpPatternL| () + (PROG () + (RETURN (AND (|bpPatternList|) (|bpPush| (|bfTuple| (|bpPop1|))))))) + +(DEFUN |bpPatternList| () + (PROG () + (RETURN + (COND + ((|bpRegularPatternItemL|) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpEqKey| 'COMMA) + (OR (|bpRegularPatternItemL|) + (PROGN + (OR (AND (|bpPatternTail|) + (|bpPush| + (APPEND (|bpPop2|) (|bpPop1|)))) + (|bpTrap|)) + NIL)))) + (RETURN NIL)) + ('T (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))))))) + T) + ('T (|bpPatternTail|)))))) + +(DEFUN |bpPatternTail| () + (PROG () + (RETURN + (AND (|bpPatternColon|) + (OR (AND (|bpEqKey| 'COMMA) + (OR (|bpRegularList|) (|bpTrap|)) + (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))) + T))))) + +(DEFUN |bpRegularBVItem| () + (PROG () + (RETURN + (OR (|bpBVString|) (|bpConstTok|) + (AND (|bpName|) + (OR (AND (|bpEqKey| 'COLON) + (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfTagged| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'BEC) (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'IS) (OR (|bpPattern|) (|bpTrap|)) + (|bpPush| (|bfAssign| (|bpPop2|) (|bpPop1|)))) + T)) + (|bpBracketConstruct| #'|bpPatternL|))))) + +(DEFUN |bpBVString| () + (PROG () + (DECLARE (SPECIAL |$ttok| |$stok|)) + (RETURN + (AND (EQ (|shoeTokType| |$stok|) 'STRING) + (|bpPush| (LIST 'BVQUOTE (INTERN |$ttok|))) (|bpNext|))))) + +(DEFUN |bpRegularBVItemL| () + (PROG () + (RETURN (AND (|bpRegularBVItem|) (|bpPush| (LIST (|bpPop1|))))))) + +(DEFUN |bpColonName| () + (PROG () + (RETURN + (AND (|bpEqKey| 'COLON) + (OR (|bpName|) (|bpBVString|) (|bpTrap|)))))) + +(DEFUN |bpBoundVariablelist| () + (PROG () + (RETURN + (COND + ((|bpRegularBVItemL|) + ((LAMBDA () + (LOOP + (COND + ((NOT (AND (|bpEqKey| 'COMMA) + (OR (|bpRegularBVItemL|) + (PROGN + (OR (AND (|bpColonName|) + (|bpPush| + (|bfColonAppend| (|bpPop2|) + (|bpPop1|)))) + (|bpTrap|)) + NIL)))) + (RETURN NIL)) + ('T (|bpPush| (APPEND (|bpPop2|) (|bpPop1|)))))))) + T) + ('T + (AND (|bpColonName|) + (|bpPush| (|bfColonAppend| NIL (|bpPop1|))))))))) + +(DEFUN |bpBeginParameterList| () + (PROG () + (DECLARE (SPECIAL |$sawParenthesizedHead|)) + (RETURN (PROGN (SETQ |$sawParenthesizedHead| NIL) T)))) + +(DEFUN |bpEndParameterList| () + (PROG () + (DECLARE (SPECIAL |$sawParenthesizedHead|)) + (RETURN (SETQ |$sawParenthesizedHead| T)))) + +(DEFUN |bpVariable| () + (PROG () + (RETURN + (OR (AND (|bpBeginParameterList|) + (|bpParenthesized| #'|bpBoundVariablelist|) + (|bpPush| (|bfTupleIf| (|bpPop1|))) + (|bpEndParameterList|)) + (|bpBracketConstruct| #'|bpPatternL|) (|bpName|) + (|bpConstTok|))))) + +(DEFUN |bpAssignVariable| () + (PROG () + (RETURN + (OR (|bpBracketConstruct| #'|bpPatternL|) (|bpAssignLHS|))))) + +(DEFUN |bpAssignLHS| () + (PROG () + (RETURN + (AND (|bpName|) + (OR (AND (|bpEqKey| 'COLON) + (OR (|bpApplication|) (|bpTrap|)) + (|bpPush| (|bfLocal| (|bpPop2|) (|bpPop1|)))) + (AND (|bpEqKey| 'DOT) + (|bpList| #'|bpPrimary| 'DOT #'|bfListOf|) + (|bpChecknull|) + (|bpPush| (|bfTuple| (CONS (|bpPop2|) (|bpPop1|))))) + T))))) + +(DEFUN |bpChecknull| () + (PROG (|a|) + (RETURN + (PROGN + (SETQ |a| (|bpPop1|)) + (COND ((NULL |a|) (|bpTrap|)) ('T (|bpPush| |a|))))))) + +(DEFUN |bpStruct| () + (PROG () + (RETURN + (AND (|bpEqKey| 'STRUCTURE) (OR (|bpName|) (|bpTrap|)) + (OR (|bpEqKey| 'DEF) (|bpTrap|)) (|bpTypeList|) + (|bpPush| (|bfStruct| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpTypeList| () + (PROG () + (RETURN + (OR (|bpPileBracketed| #'|bpTypeItemList|) + (AND (|bpTerm|) (|bpPush| (LIST (|bpPop1|)))))))) + +(DEFUN |bpTypeItemList| () + (PROG () (RETURN (|bpListAndRecover| #'|bpTerm|)))) + +(DEFUN |bpTerm| () + (PROG () + (RETURN + (OR (AND (OR (|bpName|) (|bpTrap|)) + (OR (AND (|bpParenthesized| #'|bpIdList|) + (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))) + (AND (|bpName|) + (|bpPush| (|bfNameArgs| (|bpPop2|) (|bpPop1|)))))) + (|bpPush| (|bfNameOnly| (|bpPop1|))))))) + +(DEFUN |bpIdList| () (PROG () (RETURN (|bpTuple| #'|bpName|)))) + +(DEFUN |bpCase| () + (PROG () + (RETURN + (AND (|bpEqKey| 'CASE) (OR (|bpWhere|) (|bpTrap|)) + (OR (|bpEqKey| 'OF) (|bpMissing| 'OF)) (|bpPiledCaseItems|))))) + +(DEFUN |bpPiledCaseItems| () + (PROG () + (RETURN + (AND (|bpPileBracketed| #'|bpCaseItemList|) + (|bpPush| (|bfCase| (|bpPop2|) (|bpPop1|))))))) + +(DEFUN |bpCaseItemList| () + (PROG () (RETURN (|bpListAndRecover| #'|bpCaseItem|)))) + +(DEFUN |bpCaseItem| () + (PROG () + (RETURN + (AND (OR (|bpTerm|) (|bpTrap|)) (OR (|bpEqKey| 'EXIT) (|bpTrap|)) + (OR (|bpWhere|) (|bpTrap|)) + (|bpPush| (|bfCaseItem| (|bpPop2|) (|bpPop1|))))))) + +@ + +\end{document} |