path: root/src/boot/parser.boot

-- Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
-- All rights reserved.
-- Copyright (C) 2007-2012, Gabriel Dos Reis.
-- All rights reserved.
--
-- Redistribution and use in source and binary forms, with or without
-- modification, are permitted provided that the following conditions are
-- met:
--
--     - Redistributions of source code must retain the above copyright
--       notice, this list of conditions and the following disclaimer.
--
--     - Redistributions in binary form must reproduce the above copyright
--       notice, this list of conditions and the following disclaimer in
--       the documentation and/or other materials provided with the
--       distribution.
--
--     - Neither the name of The Numerical ALgorithms Group Ltd. nor the
--       names of its contributors may be used to endorse or promote products
--       derived from this software without specific prior written permission.
--
-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
-- IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
-- TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
-- PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
-- OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
-- EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-- PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
--

--
-- Abstract:
--   This file defines the Boot grammar and parser.  The parser
--   is hand-written based on `parser combinators' technology.
--


import includer
import scanner
import ast
namespace BOOTTRAN
module parser
 
--%
--% Snapshot of the parser state
--%

structure %ParserState ==
  Record(toks: %List %Tokens, trees: %List %Ast, pren: %Short, scp: %Short,
    cur: %Token) with
      parserTokens == (.toks)       -- remaining token sequence
      parserTrees == (.trees)       -- list of successful parse trees
      parserNesting == (.pren)      -- parenthesis nesting level
      parserScope == (.scp)         -- scope nesting level
      parserCurrentToken == (.cur)  -- current token

makeParserState toks ==
  mk%ParserState(toks,nil,0,0,nil)

++ Access the value of the current token
macro parserTokenValue ps ==
  tokenValue parserCurrentToken ps

++ Access the class of the current token
macro parserTokenClass ps ==
  tokenClass parserCurrentToken ps

++ Access the position of the current token
macro parserTokenPosition ps ==
  tokenPosition parserCurrentToken ps

--%
--% 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 ps ==
  parserCurrentToken(ps) :=
    parserTokens ps = nil => mk%Token("ERROR","NOMORE",parserTokenPosition ps)
    first parserTokens ps
  $ttok := parserTokenValue ps
  true
 
bpFirstTok ps ==
  parserCurrentToken(ps) :=
    parserTokens ps = nil => mk%Token("ERROR","NOMORE",parserTokenPosition ps)
    first parserTokens ps
  $ttok := parserTokenValue ps
  parserNesting ps > 0 and parserTokenClass ps = "KEY" =>
    $ttok is "SETTAB" =>
      parserScope(ps) := parserScope ps + 1
      bpNext ps
    $ttok is "BACKTAB" =>
      parserScope(ps) := parserScope ps - 1
      bpNext ps
    $ttok is "BACKSET" =>
      bpNext ps
    true
  true
 
bpNext ps ==
  parserTokens(ps) := rest parserTokens ps
  bpFirstTok ps
 
bpNextToken ps ==
  parserTokens(ps) := rest parserTokens ps
  bpFirstToken ps
 
bpRequire(ps,f) ==
  apply(f,ps,nil) or bpTrap ps

bpState ps ==
  [parserTokens ps,parserTrees ps,parserNesting ps,parserScope ps]

 
bpRestore(ps,x)==
  parserTokens(ps) := first x
  bpFirstToken ps
  parserTrees(ps) := second x
  parserNesting(ps) := third x
  parserScope(ps) := CADDDR x
  true
 
bpPush(ps,x) ==
  parserTrees(ps) := [x,:parserTrees ps]
 
bpPushId ps ==
  parserTrees(ps) := [bfReName $ttok,:parserTrees ps]
 
bpPop1 ps ==
  a := first parserTrees ps
  parserTrees(ps) := rest parserTrees ps
  a
 
bpPop2 ps ==
  a := second parserTrees ps
  parserTrees(ps).rest := CDDR parserTrees ps
  a
 
bpPop3 ps ==
  a := third parserTrees ps
  parserTrees(ps).rest.rest := CDDDR parserTrees ps
  a
 
bpIndentParenthesized(ps,f) ==
  scope := parserScope ps
  try
    parserScope(ps) := 0
    a := parserCurrentToken ps
    bpEqPeek(ps,"OPAREN") =>
      parserNesting(ps) := parserNesting ps + 1
      bpNext ps
      apply(f,ps,nil) and bpFirstTok ps and
              (bpEqPeek(ps,"CPAREN") or bpParenTrap(ps,a)) =>
        parserNesting(ps) := parserNesting ps - 1
        bpNextToken ps
        parserScope ps = 0 => true
        parserTokens(ps) := append(bpAddTokens(ps,parserScope ps),parserTokens ps)
        bpFirstToken ps
        parserNesting ps = 0 =>
          bpCancel ps
          true
        true
      bpEqPeek(ps,"CPAREN") =>
        bpPush(ps,bfTuple [])
        parserNesting(ps) := parserNesting ps - 1
        bpNextToken ps
        true
      bpParenTrap(ps,a)
    false
  finally parserScope(ps) := scope
 
bpParenthesized(ps,f) ==
  a := parserCurrentToken ps
  bpEqKey(ps,"OPAREN") =>
    apply(f,ps,nil) and (bpEqKey(ps,"CPAREN") or bpParenTrap(ps,a)) => true
    bpEqKey(ps,"CPAREN") =>
      bpPush(ps,bfTuple [])
      true
    bpParenTrap(ps,a)
  false
 
bpBracket(ps,f) ==
  a := parserCurrentToken ps
  bpEqKey(ps,"OBRACK") =>
    apply(f,ps,nil) and (bpEqKey(ps,"CBRACK") or bpBrackTrap(ps,a)) =>
      bpPush(ps,bfBracket bpPop1 ps)
    bpEqKey(ps,"CBRACK") => bpPush(ps,[])
    bpBrackTrap(ps,a)
  false
 
bpPileBracketed(ps,f) ==
  bpEqKey(ps,"SETTAB") => 
    bpEqKey(ps,"BACKTAB") => true
    apply(f,ps,nil) and (bpEqKey(ps,"BACKTAB") or bpPileTrap ps) =>
      bpPush(ps,bfPile bpPop1 ps)
    false
  false
 
bpListof(ps,f,str1,g)==
  apply(f,ps,nil) =>
    bpEqKey(ps,str1) and bpRequire(ps,f) =>
      a := parserTrees ps
      parserTrees(ps) := nil
      while bpEqKey(ps,str1) and bpRequire(ps,f) repeat nil
      parserTrees(ps) := [reverse! parserTrees ps,:a]
      bpPush(ps,FUNCALL(g, [bpPop3 ps,bpPop2 ps,:bpPop1 ps]))
    true
  false
 
 
-- to do ,<backset>
bpListofFun(ps,f,h,g)==
  apply(f,ps,nil) =>
    apply(h,ps,nil) and bpRequire(ps,f) =>
      a := parserTrees ps
      parserTrees(ps) := nil
      while apply(h,ps,nil) and bpRequire(ps,f) repeat nil
      parserTrees(ps) := [reverse! parserTrees ps,:a]
      bpPush(ps,FUNCALL(g, [bpPop3 ps,bpPop2 ps,:bpPop1 ps]))
    true
  false
 
bpList(ps,f,str1)==
  apply(f,ps,nil) =>
    bpEqKey(ps,str1) and bpRequire(ps,f) =>
      a := parserTrees ps
      parserTrees(ps) := nil
      while bpEqKey(ps,str1) and bpRequire(ps,f) repeat nil
      parserTrees(ps) := [reverse! parserTrees ps,:a]
      bpPush(ps,[bpPop3 ps,bpPop2 ps,:bpPop1 ps])
    bpPush(ps,[bpPop1 ps])
  bpPush(ps,nil)
 
bpOneOrMore(ps,f) ==
  apply(f,ps,nil)=>
    a := parserTrees ps
    parserTrees(ps) := nil
    while apply(f,ps,nil) repeat nil
    parserTrees(ps) := [reverse! parserTrees ps,:a]
    bpPush(ps,[bpPop2 ps,:bpPop1 ps])
  false
 
 
-- s must transform the head of the stack
bpAnyNo(ps,s) ==
  while apply(s,ps,nil) repeat nil
  true
 
 
-- AndOr(k,p,f)= k p
bpAndOr(ps,keyword,p,f)==
  bpEqKey(ps,keyword) and bpRequire(ps,p)
    and bpPush(ps,FUNCALL(f, bpPop1 ps))
 
bpConditional(ps,f) ==
  bpEqKey(ps,"IF") and bpRequire(ps,function bpWhere) and (bpEqKey(ps,"BACKSET") or true) =>
    bpEqKey(ps,"SETTAB") =>
      bpEqKey(ps,"THEN") =>
	bpRequire(ps,f) and bpElse(ps,f) and bpEqKey(ps,"BACKTAB")
      bpMissing(ps,"THEN")
    bpEqKey(ps,"THEN") => bpRequire(ps,f) and bpElse(ps,f)
    bpMissing(ps,"then")
  false
 
bpElse(ps,f)==
  a := bpState ps
  bpBacksetElse ps =>
    bpRequire(ps,f) and
      bpPush(ps,bfIf(bpPop3 ps,bpPop2 ps,bpPop1 ps))
  bpRestore(ps,a)
  bpPush(ps,bfIfThenOnly(bpPop2 ps,bpPop1 ps))
 
bpBacksetElse ps ==
  bpEqKey(ps,"BACKSET") => bpEqKey(ps,"ELSE")
  bpEqKey(ps,"ELSE")
 
bpEqPeek(ps,s) == 
  parserTokenClass ps = "KEY" and symbolEq?(s,$ttok)
 
bpEqKey(ps,s) ==
  parserTokenClass ps = "KEY" and symbolEq?(s,$ttok) and bpNext ps

bpEqKeyNextTok(ps,s) ==   
  parserTokenClass ps = "KEY" and symbolEq?(s,$ttok) and bpNextToken ps
 
bpPileTrap ps   == bpMissing(ps,"BACKTAB")
bpBrackTrap(ps,x) == bpMissingMate(ps,"]",x)
bpParenTrap(ps,x) == bpMissingMate(ps,")",x)
 
bpSpecificErrorHere(ps,key) ==
  bpSpecificErrorAtToken(parserCurrentToken ps, key)

bpSpecificErrorAtToken(tok, key) ==
  a := tokenPosition tok
  SoftShoeError(a,key)
 
bpGeneralErrorHere ps ==
  bpSpecificErrorHere(ps,'"syntax error")
 
bpIgnoredFromTo(pos1, pos2) ==
  shoeConsole strconc('"ignored from line ", toString lineNo pos1)
  shoeConsole lineString pos1
  shoeConsole strconc(shoeSpaces lineCharacter pos1,'"|")
  shoeConsole strconc('"ignored through line ", toString lineNo pos2)
  shoeConsole lineString pos2
  shoeConsole strconc(shoeSpaces lineCharacter pos2,'"|")

bpMissingMate(ps,close,open)==
  bpSpecificErrorAtToken(open, '"possibly missing mate")
  bpMissing(ps,close)
 
bpMissing(ps,s) ==
  bpSpecificErrorHere(ps,strconc(PNAME s,'" possibly missing"))
  throw 'TRAPPED : BootParserException
 
bpCompMissing(ps,s) ==
  bpEqKey(ps,s) or bpMissing(ps,s)
 
bpTrap ps ==
  bpGeneralErrorHere ps
  throw 'TRAPPED : BootParserException
 
bpRecoverTrap ps ==
  bpFirstToken ps
  pos1 := parserTokenPosition ps
  bpMoveTo(ps,0)
  pos2 := parserTokenPosition ps
  bpIgnoredFromTo(pos1, pos2)
  bpPush(ps,[['"pile syntax error"]])
 
bpListAndRecover(ps,f)==
  a := parserTrees ps
  b := nil
  parserTrees(ps) := nil
  done := false
  c := parserTokens ps
  while not done repeat
    found :=
      try apply(f,ps,nil)
      catch(e: BootParserException) => e
    if found is "TRAPPED"
    then
       parserTokens(ps) := c
       bpRecoverTrap ps
    else if not found
	 then
	   parserTokens(ps) := c
	   bpGeneralErrorHere ps
	   bpRecoverTrap ps
    if bpEqKey(ps,"BACKSET")
    then
       c := parserTokens ps
    else if bpEqPeek(ps,"BACKTAB") or parserTokens ps = nil
	 then
	    done := true
	 else
	   parserTokens(ps) := c
	   bpGeneralErrorHere ps
	   bpRecoverTrap ps
	   if bpEqPeek(ps,"BACKTAB")  or parserTokens ps = nil
	   then done:=true
	   else
	       bpNext ps
	       c := parserTokens ps
    b := [bpPop1 ps,:b]
  parserTrees(ps) := a
  bpPush(ps,reverse! b)
 
bpMoveTo(ps,n) ==
   parserTokens ps = nil  => true
   bpEqPeek(ps,"BACKTAB") =>
     n=0  => true
     bpNextToken ps
     parserScope(ps) := parserScope ps - 1
     bpMoveTo(ps,n-1)
   bpEqPeek(ps,"BACKSET") =>
     n=0  => true
     bpNextToken ps
     bpMoveTo(ps,n)
   bpEqPeek(ps,"SETTAB")  =>
     bpNextToken ps
     bpMoveTo(ps,n+1)
   bpEqPeek(ps,"OPAREN")  =>
     bpNextToken ps
     parserNesting(ps) := parserNesting(ps) + 1
     bpMoveTo(ps,n)
   bpEqPeek(ps,"CPAREN")  =>
     bpNextToken ps
     parserNesting(ps) := parserNesting ps - 1
     bpMoveTo(ps,n)
   bpNextToken ps
   bpMoveTo(ps,n)
 
-- A fully qualified name could be interpreted as a left reduction
-- of an '::' infix operator.  At the moment, we don't use
-- that general interpretation.

-- When this routine is called, a symbol is already pushed on the
-- stack.  When this routine finished execution, we have either
-- reduced a '::' and a name, or nothing.  In either case, a 
-- symbol is present on the stack.
bpQualifiedName ps ==
  bpEqPeek(ps,"COLON-COLON") =>
    bpNext ps
    parserTokenClass ps = "ID" and bpPushId ps and bpNext ps
      and bpPush(ps,bfColonColon(bpPop2 ps, bpPop1 ps))
  false

++ Name:
++   ID
++   Name :: ID
bpName ps ==
  parserTokenClass ps = "ID" =>
    bpPushId ps
    bpNext ps
    bpAnyNo(ps,function bpQualifiedName)
  false

++ Constant:
++   INTEGER
++   FLOAT
++   LISP
++   LISPEXPR
++   LINE
++   QUOTE S-Expression
++   STRING
bpConstTok ps ==
  parserTokenClass ps in '(INTEGER FLOAT) =>
    bpPush(ps,$ttok)
    bpNext ps
  parserTokenClass ps = "LISP" => bpPush(ps,%Lisp $ttok) and bpNext ps
  parserTokenClass ps = "LISPEXP" => bpPush(ps,$ttok) and bpNext ps
  parserTokenClass ps = "LINE" => bpPush(ps,["+LINE", $ttok]) and bpNext ps
  bpEqPeek(ps,"QUOTE") =>
    bpNext ps
    bpRequire(ps,function bpSexp) and
      bpPush(ps,bfSymbol bpPop1 ps)
  bpString ps or bpFunction ps

bpChar ps ==
  parserTokenClass ps = "ID" and $ttok is "char" =>
    a := bpState ps
    bpApplication ps =>
      s := bpPop1 ps
      s is ["char",.] => bpPush(ps,s)
      bpRestore(ps,a)
      false
    false
  false

++ Subroutine of bpExportItem.  Parses tails of ExportItem.
bpExportItemTail ps ==
  bpEqKey(ps,"BEC") and bpRequire(ps,function bpAssign) and
    bpPush(ps,%Assignment(bpPop2 ps, bpPop1 ps))
      or bpSimpleDefinitionTail ps

++ ExportItem:
++   Structure
++   TypeAliasDefinition
++   Signature
++   Signature := Where
++   Signature  == Where
bpExportItem ps ==
  bpEqPeek(ps,"STRUCTURE") => bpStruct ps
  a := bpState ps
  bpName ps =>
    bpEqPeek(ps,"COLON") =>
      bpRestore(ps,a)
      bpRequire(ps,function bpSignature)
      bpExportItemTail ps or true
    bpRestore(ps,a)
    bpTypeAliasDefition ps
  false

++ ExportItemList:
++    Signature
++    ExportItemList Signature
bpExportItemList ps ==
  bpListAndRecover(ps,function bpExportItem)

++ ModuleInterface:
++   WHERE pile-bracketed ExporItemList
bpModuleInterface ps ==
  bpEqKey(ps,"WHERE") =>
    bpPileBracketed(ps,function bpExportItemList)
      or (bpExportItem ps and bpPush(ps,[bpPop1 ps]))
        or bpTrap ps
  bpPush(ps,nil)

++ ModuleExports:
++   OPAREN IdList CPAREN
bpModuleExports ps ==
  bpParenthesized(ps,function bpIdList) => bpPush(ps,bfUntuple bpPop1 ps)
  bpPush(ps,nil)

++ Parse a module definitoin
++   Module:
++     MODULE Name OptionalModuleExports OptionalModuleInterface
bpModule ps ==
  bpEqKey(ps,"MODULE") => 
    bpRequire(ps,function bpName)
    bpModuleExports ps
    bpModuleInterface ps
    bpPush(ps,%Module(bpPop3 ps,bpPop2 ps,bpPop1 ps))
  nil

++ Parse a module import, or a import declaration for a foreign entity.
++ Import:
++    IMPORT Signature FOR Name
++    IMPORT Name
++    IMPORT NAMESPACE LongName
bpImport ps ==
  bpEqKey(ps,"IMPORT") =>
    bpEqKey(ps,"NAMESPACE") =>
      bpLeftAssoc(ps,'(DOT),function bpName) and
        bpPush(ps,%Import bfNamespace bpPop1 ps)
          or bpTrap ps
    a := bpState ps
    bpRequire(ps,function bpName)
    bpEqPeek(ps,"COLON") =>
      bpRestore(ps,a)
      bpRequire(ps,function bpSignature) and 
        (bpEqKey(ps,"FOR") or bpTrap ps) and
           bpRequire(ps,function bpName) and
              bpPush(ps,%ImportSignature(bpPop1 ps, bpPop1 ps))
    bpPush(ps,%Import bpPop1 ps)
  false

++
++ Namespace:
++    NAMESPACE Name
bpNamespace ps ==
  bpEqKey(ps,"NAMESPACE") and (bpName ps or bpDot ps) and
    bpPush(ps,bfNamespace bpPop1 ps)

-- Parse a type alias defnition:
--    type-alias-definition: 
--          identifier <=> logical-expression
bpTypeAliasDefition ps ==
  (bpTerm(ps,function bpIdList) or bpTrap ps) and 
    bpEqKey(ps,"TDEF") and bpLogical ps and
      bpPush(ps,%TypeAlias(bpPop2 ps, bpPop1 ps))

++ Parse a signature declaration
++  Signature:
++    Name COLON Mapping
bpSignature ps ==
  bpName ps and bpEqKey(ps,"COLON") and bpRequire(ps,function bpTyping)
    and bpPush(ps,%Signature(bpPop2 ps, bpPop1 ps))

++ SimpleMapping:
++   Application
++   Application -> Application
bpSimpleMapping ps ==
  bpApplication ps =>
    bpEqKey(ps,"ARROW") and bpRequire(ps,function bpApplication) and
      bpPush(ps,%Mapping(bpPop1 ps, [bpPop1 ps]))
    true
  false

++ ArgtypeList:
++   ( ArgtypeSequence )
++ ArgtypeSequence:
++   SimpleMapping
++   SimpleMapping , ArgtypeSequence
bpArgtypeList ps ==
  bpTuple(ps,function bpSimpleMapping)

++ Parse a mapping expression
++   Mapping:
++     ArgtypeList -> Application
bpMapping ps ==
  bpParenthesized(ps,function bpArgtypeList) and 
     bpEqKey(ps,"ARROW") and bpApplication ps and 
       bpPush(ps,%Mapping(bpPop1 ps, bfUntuple bpPop1 ps))

bpCancel ps ==
  a := bpState ps
  bpEqKeyNextTok(ps,"SETTAB") =>
    bpCancel ps =>
      bpEqKeyNextTok(ps,"BACKTAB") => true
      bpRestore(ps,a)
      false
    bpEqKeyNextTok(ps,"BACKTAB") => true
    bpRestore(ps,a)
    false
  false

bpAddTokens(ps,n) ==
  n=0 => nil
  n>0=> [mk%Token("KEY","SETTAB",parserTokenPosition ps),:bpAddTokens(ps,n-1)]
  [mk%Token("KEY","BACKTAB",parserTokenPosition ps),:bpAddTokens(ps,n+1)]
 
bpExceptions ps ==
  bpEqPeek(ps,"DOT") or bpEqPeek(ps,"QUOTE") or
       bpEqPeek(ps,"OPAREN") or bpEqPeek(ps,"CPAREN") or
          bpEqPeek(ps,"SETTAB") or bpEqPeek(ps,"BACKTAB")
             or bpEqPeek(ps,"BACKSET")
 
 
bpSexpKey ps ==
  parserTokenClass ps = "KEY" and not bpExceptions ps =>
    a := $ttok has SHOEINF
    a = nil => bpPush(ps,keywordId $ttok) and bpNext ps
    bpPush(ps,a) and bpNext ps
  false
 
bpAnyId ps ==
  bpEqKey(ps,"MINUS") and (parserTokenClass ps = "INTEGER" or bpTrap ps) and
    bpPush(ps,-$ttok) and bpNext ps
      or bpSexpKey ps
        or parserTokenClass ps in '(ID INTEGER STRING FLOAT) and
             bpPush(ps,$ttok) and  bpNext ps
 
bpSexp ps ==
  bpAnyId ps or
      bpEqKey(ps,"QUOTE") and bpRequire(ps,function bpSexp)
         and bpPush(ps,bfSymbol bpPop1 ps) or
             bpIndentParenthesized(ps,function bpSexp1)
 
bpSexp1 ps == bpFirstTok ps and
  bpSexp ps and
   (bpEqKey(ps,"DOT") and bpSexp ps and bpPush(ps,[bpPop2 ps,:bpPop1 ps]) or
         bpSexp1 ps and bpPush(ps,[bpPop2 ps,:bpPop1 ps])) or
             bpPush(ps,nil)
 
bpPrimary1 ps ==
  bpParenthesizedApplication ps or
    bpDot ps or
      bpConstTok ps or 
        bpConstruct ps or
          bpCase ps or
            bpStruct ps or
              bpPDefinition ps or
                bpBPileDefinition ps

bpParenthesizedApplication ps ==
  bpName ps and bpAnyNo(ps,function bpArgumentList)

bpArgumentList ps ==
  bpPDefinition ps and 
    bpPush(ps,bfApplication(bpPop2 ps, bpPop1 ps))
 
bpPrimary ps ==
  bpFirstTok ps and (bpPrimary1 ps or bpPrefixOperator ps )
 
bpDot ps ==
  bpEqKey(ps,"DOT") and bpPush(ps,bfDot())
 
bpPrefixOperator ps ==
   parserTokenClass ps = "KEY" and
     $ttok has SHOEPRE and bpPushId ps and  bpNext ps
 
bpInfixOperator ps ==
  parserTokenClass ps = "KEY" and
    $ttok has SHOEINF and bpPushId ps and  bpNext ps
 
bpSelector ps ==
  bpEqKey(ps,"DOT") and (bpPrimary ps
     and bpPush(ps,bfElt(bpPop2 ps,bpPop1 ps))
	or bpPush(ps,bfSuffixDot bpPop1 ps))
 
bpApplication ps==
   bpPrimary ps and bpAnyNo(ps,function bpSelector) and
      (bpApplication ps and
            bpPush(ps,bfApplication(bpPop2 ps,bpPop1 ps)) or true)
              or bpNamespace ps
 
++ Typing:
++   SimpleType
++   Mapping
++   FORALL Variable DOT Typing
bpTyping ps ==
  bpEqKey(ps,"FORALL") =>
    bpRequire(ps,function bpVariable)
    (bpDot ps and bpPop1 ps) or bpTrap ps
    bpRequire(ps,function bpTyping)
    bpPush(ps,%Forall(bpPop2 ps, bpPop1 ps))
  bpMapping ps or bpSimpleMapping ps

++ Typed:
++   Application : Typing
++   Application @ Typing
bpTyped ps ==
  bpApplication ps and
     bpEqKey(ps,"COLON") =>
       bpRequire(ps,function bpTyping) and
         bpPush(ps,bfTagged(bpPop2 ps,bpPop1 ps))
     bpEqKey(ps,"AT") =>
       bpRequire(ps,function bpTyping) and
         bpPush(ps,bfRestrict(bpPop2 ps, bpPop1 ps))
     true
 
bpExpt ps == bpRightAssoc(ps,'(POWER),function bpTyped)
 
bpInfKey(ps,s) ==
  parserTokenClass ps = "KEY" and
    symbolMember?($ttok,s) and bpPushId ps and bpNext ps
 
bpInfGeneric(ps,s) ==
  bpInfKey(ps,s) and (bpEqKey(ps,"BACKSET") or true)
 
bpRightAssoc(ps,o,p)==
  a := bpState ps
  apply(p,ps,nil) =>
    while  bpInfGeneric(ps,o) and (bpRightAssoc(ps,o,p) or bpTrap ps) repeat
      bpPush(ps,bfInfApplication(bpPop2 ps,bpPop2 ps,bpPop1 ps))
    true
  bpRestore(ps,a)
  false
 
bpLeftAssoc(ps,operations,parser)==
  apply(parser,ps,nil) =>
    while bpInfGeneric(ps,operations) and bpRequire(ps,parser)
     repeat
       bpPush(ps,bfInfApplication(bpPop2 ps,bpPop2 ps,bpPop1 ps))
    true
  false
 
bpString ps ==
  parserTokenClass ps = "STRING" and
    bpPush(ps,quote makeSymbol $ttok) and bpNext ps
 
bpFunction ps ==
  bpEqKey(ps,"FUNCTION") and bpRequire(ps,function bpPrimary1)
    and bpPush(ps,bfFunction bpPop1 ps)

bpThetaName ps ==
  parserTokenClass ps = "ID" and $ttok has SHOETHETA =>
    bpPushId ps
    bpNext ps
  false
 
bpReduceOperator ps ==
   bpInfixOperator ps or bpString ps or bpThetaName ps
 
bpReduce ps ==
  a := bpState ps
  bpReduceOperator ps and bpEqKey(ps,"SLASH") =>
    bpEqPeek(ps,"OBRACK") => 
      bpRequire(ps,function bpDConstruct) and
	bpPush(ps,bfReduceCollect(bpPop2 ps,bpPop1 ps))
    bpRequire(ps,function bpApplication) and
      bpPush(ps,bfReduce(bpPop2 ps,bpPop1 ps))
  bpRestore(ps,a)
  false
 
bpTimes ps ==
    bpReduce ps or bpLeftAssoc(ps,'(TIMES  SLASH),function bpExpt)

bpEuclid ps ==
  bpLeftAssoc(ps,'(QUO REM),function bpTimes)
 
bpMinus ps ==
  bpInfGeneric(ps,'(MINUS)) and bpRequire(ps,function bpEuclid)
    and bpPush(ps,bfApplication(bpPop2 ps,bpPop1 ps))
      or bpEuclid ps
 
bpArith ps ==
  bpLeftAssoc(ps,'(PLUS MINUS),function bpMinus)
 
bpIs ps ==
  bpArith ps and
     bpInfKey(ps,'(IS ISNT)) and bpRequire(ps,function bpPattern) =>
       bpPush(ps,bfISApplication(bpPop2 ps,bpPop2 ps,bpPop1 ps))
     bpEqKey(ps,"HAS") and bpRequire(ps,function bpApplication) =>
       bpPush(ps,bfHas(bpPop2 ps, bpPop1 ps))
     true
 
bpBracketConstruct(ps,f)==
  bpBracket(ps,f) and bpPush(ps,bfConstruct bpPop1 ps)
 
bpCompare ps ==
  bpIs ps and (bpInfKey(ps,'(SHOEEQ SHOENE LT LE GT GE IN))
     and bpRequire(ps,function bpIs)
	and bpPush(ps,bfInfApplication(bpPop2 ps,bpPop2 ps,bpPop1 ps))
	    or true)
              or bpLeave ps
                or bpThrow ps
 
bpAnd ps == 
  bpLeftAssoc(ps,'(AND),function bpCompare)

bpThrow ps ==
  bpEqKey(ps,"THROW") and bpApplication ps =>
    -- Allow user-supplied matching type tag
    if bpEqKey(ps,"COLON") then
      bpRequire(ps,function bpApplication)
      bpPush(ps,%Pretend(bpPop2 ps,bpPop1 ps))
    bpPush(ps,bfThrow bpPop1 ps)
  nil

++  Try:
++    try Assign CatchItems
bpTry ps ==
  bpEqKey(ps,"TRY") =>
    bpAssign ps
    cs := []
    while bpHandler(ps,"CATCH") repeat
      bpCatchItem ps
      cs := [bpPop1 ps,:cs]
    bpHandler(ps,"FINALLY") =>
      bpFinally ps and
        bpPush(ps,bfTry(bpPop2 ps,reverse! [bpPop1 ps,:cs]))
    cs = nil => bpTrap ps -- missing handlers
    bpPush(ps,bfTry(bpPop1 ps,reverse! cs))
  nil            

bpCatchItem ps ==
  bpRequire(ps,function bpExceptionVariable) and
    (bpEqKey(ps,"EXIT") or bpTrap ps) and
      bpRequire(ps,function bpAssign) and
        bpPush(ps,%Catch(bpPop2 ps,bpPop1 ps))

bpExceptionVariable ps ==
  t := parserCurrentToken ps
  bpEqKey(ps,"OPAREN") and 
    bpRequire(ps,function bpSignature) and
      (bpEqKey(ps,"CPAREN") or bpMissing(ps,t))
        or bpTrap ps

bpFinally ps ==
  bpRequire(ps,function bpAssign) and
    bpPush(ps,%Finally bpPop1 ps)

bpHandler(ps,key) ==
  s := bpState ps
  (bpEqKey(ps,"BACKSET") or bpEqKey(ps,"SEMICOLON")) and bpEqKey(ps,key) => true
  bpRestore(ps,s)
  false

++ Leave:
++   LEAVE Logical
bpLeave ps ==
  bpEqKey(ps,"LEAVE") and bpRequire(ps,function bpLogical) and
    bpPush(ps,bfLeave bpPop1 ps)

++ Do:
++  IN Namespace Do
++  DO Assign
bpDo ps ==
  bpEqKey(ps,"IN") =>
    bpRequire(ps,function bpNamespace)
    bpRequire(ps,function bpDo)
    bpPush(ps,bfAtScope(bpPop2 ps,bpPop1 ps))
  bpEqKey(ps,"DO") and bpRequire(ps,function bpAssign) and
    bpPush(ps,bfDo bpPop1 ps)

++ Return:
++   RETURN Assign
++   Leave
++   Throw
++   And
bpReturn ps==
  (bpEqKey(ps,"RETURN") and bpRequire(ps,function bpAssign) and
	 bpPush(ps,bfReturnNoName bpPop1 ps)) 
    or bpLeave ps
      or bpThrow ps
        or bpAnd ps
          or bpDo ps
 
 
bpLogical ps ==
  bpLeftAssoc(ps,'(OR),function bpReturn)
 
bpExpression ps ==
  bpEqKey(ps,"COLON") and (bpLogical ps and
     bpPush(ps,bfApplication ("COLON",bpPop1 ps))
           or bpTrap ps) or bpLogical ps
 
bpStatement ps ==
  bpConditional(ps,function bpWhere) or bpLoop ps
    or bpExpression ps
      or bpTry ps
 
bpLoop ps ==
  bpIterators ps and
   (bpCompMissing(ps,"REPEAT") and
      bpRequire(ps,function bpWhere) and
         bpPush(ps,bfLp(bpPop2 ps,bpPop1 ps)))
             or
               bpEqKey(ps,"REPEAT") and bpRequire(ps,function bpLogical) and
                    bpPush(ps,bfLoop1 bpPop1 ps)
 
bpSuchThat ps ==
  bpAndOr(ps,"BAR",function bpWhere,function bfSuchthat)
 
bpWhile ps ==
  bpAndOr(ps,"WHILE",function bpLogical,function bfWhile)
 
bpUntil ps ==
  bpAndOr(ps,"UNTIL",function bpLogical,function bfUntil)
 
bpFormal ps ==
  bpVariable ps or bpDot ps

bpForIn ps ==
  bpEqKey(ps,"FOR") and bpRequire(ps,function bpFormal) and (bpCompMissing(ps,"IN"))
      and (bpRequire(ps,function bpSeg) and
       (bpEqKey(ps,"BY") and bpRequire(ps,function bpArith) and
        bpPush(ps,bfForInBy(bpPop3 ps,bpPop2 ps,bpPop1 ps))) or
         bpPush(ps,bfForin(bpPop2 ps,bpPop1 ps)))
 
bpSeg ps ==
   bpArith ps and
      (bpEqKey(ps,"SEG") and
       (bpArith ps and bpPush(ps,bfSegment2(bpPop2 ps,bpPop1 ps))
         or bpPush(ps,bfSegment1(bpPop1 ps))) or true)
 
bpIterator ps ==
  bpForIn ps or bpSuchThat ps or bpWhile ps or bpUntil ps
 
bpIteratorList ps ==
  bpOneOrMore(ps,function bpIterator)
    and bpPush(ps,bfIterators bpPop1 ps)
 
bpCrossBackSet ps ==
  bpEqKey(ps,"CROSS") and (bpEqKey(ps,"BACKSET") or true)
 
bpIterators ps ==
  bpListofFun(ps,function bpIteratorList,
    function bpCrossBackSet,function bfCross)
 
bpAssign ps ==
  a := bpState ps
  bpStatement ps =>
    bpEqPeek(ps,"BEC") =>
      bpRestore(ps,a)
      bpRequire(ps,function bpAssignment)
    bpEqPeek(ps,"GIVES") =>
      bpRestore(ps,a)
      bpRequire(ps,function bpLambda)
    bpEqPeek(ps,"LARROW") =>
      bpRestore(ps,a)
      bpRequire(ps,function bpKeyArg)
    true
  bpRestore(ps,a)
  false
 
bpAssignment ps ==
  bpAssignVariable ps and
    bpEqKey(ps,"BEC") and
      bpRequire(ps,function bpAssign) and
	 bpPush(ps,bfAssign(bpPop2 ps,bpPop1 ps))
 
++ Parse a lambda expression
++   Lambda ::= Variable +-> Assign
bpLambda ps ==
  bpVariable ps and
    bpEqKey(ps,"GIVES") and
      bpRequire(ps,function bpAssign) and
        bpPush(ps,bfLambda(bpPop2 ps,bpPop1 ps))

bpKeyArg ps ==
  bpName ps and bpEqKey(ps,"LARROW") and bpLogical ps and
    bpPush(ps,bfKeyArg(bpPop2 ps,bpPop1 ps))

-- should only be allowed in sequences
bpExit ps ==
  bpAssign ps and (bpEqKey(ps,"EXIT") and
      (bpRequire(ps,function bpWhere) and
	 bpPush(ps,bfExit(bpPop2 ps,bpPop1 ps)))
	   or true)

bpDefinition ps ==
  bpEqKey(ps,"MACRO") =>
    bpName ps and bpStoreName ps and
      bpCompoundDefinitionTail(ps,function %Macro)
        or bpTrap ps
  a := bpState ps
  bpExit ps =>
    bpEqPeek(ps,"DEF") =>
       bpRestore(ps,a)
       bpDef ps
    bpEqPeek(ps,"TDEF") =>
       bpRestore(ps,a)
       bpTypeAliasDefition ps
    true
  bpRestore(ps,a)
  false
 
bpStoreName ps ==
  $op := first parserTrees ps
  $wheredefs := nil
  $typings := nil
  true

bpDef ps ==  
  bpName ps and bpStoreName ps and bpDefTail(ps,function %Definition)
    or bpNamespace ps and bpSimpleDefinitionTail ps
 
bpDDef ps ==
  bpName ps and bpDefTail(ps,function %Definition)

++ Parse the remaining of a simple definition.
bpSimpleDefinitionTail ps ==
  bpEqKey(ps,"DEF") and
    bpRequire(ps,function bpWhere)
      and bpPush(ps,%ConstantDefinition(bpPop2 ps, bpPop1 ps))

++ Parse the remaining of a compound definition.
bpCompoundDefinitionTail(ps,f) ==
  bpVariable ps and 
    bpEqKey(ps,"DEF") and bpRequire(ps,function bpWhere) and 
      bpPush(ps,apply(f,[bpPop3 ps,bpPop2 ps,bpPop1 ps]))


++ Parse the remainding of a definition.  When we reach this point
++ we know we must parse a definition and we have already parsed
++ the name of the main operator in the definition.
bpDefTail(ps,f) ==
  bpSimpleDefinitionTail ps
    or bpCompoundDefinitionTail(ps,f)
 
bpWhere ps ==
    bpDefinition ps and
       (bpEqKey(ps,"WHERE") and bpRequire(ps,function bpDefinitionItem)
           and bpPush(ps,bfWhere(bpPop1 ps,bpPop1 ps)) or true)
 
bpDefinitionItem ps ==
  a := bpState ps
  bpDDef ps => true
  bpRestore(ps,a)
  bpBDefinitionPileItems ps => true
  bpRestore(ps,a)
  bpPDefinitionItems ps => true
  bpRestore(ps,a)
  bpWhere ps
 
bpDefinitionPileItems ps ==
  bpListAndRecover(ps,function bpDefinitionItem)
    and bpPush(ps,%Pile bpPop1 ps)
 
bpBDefinitionPileItems ps ==
  bpPileBracketed(ps,function bpDefinitionPileItems)
 
bpSemiColonDefinition ps ==
  bpSemiListing(ps,function bpDefinitionItem,function %Pile)
 
bpPDefinitionItems ps ==
  bpParenthesized(ps,function bpSemiColonDefinition)
 
bpComma ps == 
  bpModule ps or bpImport ps or bpTuple(ps,function bpWhere)
 
bpTuple(ps,p) ==
  bpListofFun(ps,p,function bpCommaBackSet,function bfTuple)
 
bpCommaBackSet ps == 
  bpEqKey(ps,"COMMA") and (bpEqKey(ps,"BACKSET") or true)
 
bpSemiColon ps == 
  bpSemiListing(ps,function bpComma,function bfSequence)
 
bpSemiListing(ps,p,f) ==
  bpListofFun(ps,p,function bpSemiBackSet,f)
 
bpSemiBackSet ps == 
  bpEqKey(ps,"SEMICOLON") and (bpEqKey(ps,"BACKSET") or true)
 
bpPDefinition ps ==
  bpIndentParenthesized(ps,function bpSemiColon)
 
bpPileItems ps ==
  bpListAndRecover(ps,function bpSemiColon) and bpPush(ps,bfSequence bpPop1 ps)
 
bpBPileDefinition ps ==
  bpPileBracketed(ps,function bpPileItems)
 
bpIteratorTail ps ==
  (bpEqKey(ps,"REPEAT") or true) and bpIterators ps
 
bpConstruct ps ==
  bpBracket(ps,function bpConstruction)
 
bpConstruction ps==
  bpComma ps and
     (bpIteratorTail ps and
	  bpPush(ps,bfCollect(bpPop2 ps,bpPop1 ps)) or
	     bpPush(ps,bfTupleConstruct bpPop1 ps))
 
bpDConstruct ps ==
  bpBracket(ps,function bpDConstruction)
 
bpDConstruction ps ==
  bpComma ps and
     (bpIteratorTail ps and
	  bpPush(ps,bfDCollect(bpPop2 ps,bpPop1 ps)) or
	     bpPush(ps,bfDTuple bpPop1 ps))
 
 
 
--PATTERN
 
bpPattern ps ==
  bpBracketConstruct(ps,function bpPatternL)
    or bpChar ps or bpName ps or bpConstTok ps
 
bpEqual ps ==
   bpEqKey(ps,"SHOEEQ") and (bpApplication ps or bpConstTok ps or
                bpTrap ps) and bpPush(ps,bfEqual bpPop1 ps)
 
bpRegularPatternItem ps ==
   bpEqual ps or
     bpConstTok ps or bpDot ps or
      bpName ps and
         ((bpEqKey(ps,"BEC") and bpRequire(ps,function bpPattern)
              and bpPush(ps,bfAssign(bpPop2 ps,bpPop1 ps))) or true)
                    or bpBracketConstruct(ps,function bpPatternL)
 
bpRegularPatternItemL ps ==
      bpRegularPatternItem ps and bpPush(ps,[bpPop1 ps])
 
bpRegularList ps ==
       bpListof(ps,function bpRegularPatternItemL,"COMMA",function bfAppend)
 
bpPatternColon ps ==
  bpEqKey(ps,"COLON") and bpRequire(ps,function bpRegularPatternItem)
    and bpPush(ps,[bfColon bpPop1 ps])
 
 
-- only one colon
bpPatternL ps ==
  bpPatternList ps and bpPush(ps,bfTuple bpPop1 ps)
 
bpPatternList ps ==
  bpRegularPatternItemL ps =>
    while (bpEqKey(ps,"COMMA") and (bpRegularPatternItemL ps or
	(bpPatternTail ps
	  and bpPush(ps,append(bpPop2 ps,bpPop1 ps))
	    or bpTrap ps;false) )) repeat
	      bpPush(ps,append(bpPop2 ps,bpPop1 ps))
    true
  bpPatternTail ps
 
bpPatternTail ps ==
  bpPatternColon ps and
      (bpEqKey(ps,"COMMA") and bpRequire(ps,function bpRegularList)
	   and bpPush(ps,append(bpPop2 ps,bpPop1 ps)) or true)
 
-- BOUND VARIABLE

++ We are parsing parameters in a function definition.  We have
++ just seen a parameter name; we are attempting to see whether
++ it might be followed by a type annotation, or whether it actually
++ a form with a specific pattern structure, or whether it has
++ a default value.
bpRegularBVItemTail ps ==
  bpEqKey(ps,"COLON") and bpRequire(ps,function bpApplication) and 
    bpPush(ps,bfTagged(bpPop2 ps, bpPop1 ps))
      or bpEqKey(ps,"BEC") and bpRequire(ps,function bpPattern) and
	 bpPush(ps,bfAssign(bpPop2 ps,bpPop1 ps))
	   or bpEqKey(ps,"IS") and bpRequire(ps,function bpPattern) and
	      bpPush(ps,bfAssign(bpPop2 ps,bpPop1 ps))
             or bpEqKey(ps,"DEF") and bpRequire(ps,function bpApplication) and
                bpPush(ps,%DefaultValue(bpPop2 ps, bpPop1 ps))


bpRegularBVItem ps ==
  bpBVString ps 
    or bpConstTok ps 
      or (bpName ps and (bpRegularBVItemTail ps or true))
        or bpBracketConstruct(ps,function bpPatternL)
 
bpBVString ps ==
  parserTokenClass ps = "STRING" and
      bpPush(ps,["BVQUOTE",makeSymbol $ttok]) and bpNext ps
 
bpRegularBVItemL ps ==
  bpRegularBVItem ps and bpPush(ps,[bpPop1 ps])
 
bpColonName ps ==
  bpEqKey(ps,"COLON") and (bpName ps or bpBVString ps or bpTrap ps)
 
 
-- at most one colon at end
bpBoundVariablelist ps ==
  bpRegularBVItemL ps =>
    while (bpEqKey(ps,"COMMA") and (bpRegularBVItemL ps or
	(bpColonName ps
	  and bpPush(ps,bfColonAppend(bpPop2 ps,bpPop1 ps))
	    or bpTrap ps;false) )) repeat
	       bpPush(ps,append(bpPop2 ps,bpPop1 ps))
    true
  bpColonName ps and bpPush(ps,bfColonAppend(nil,bpPop1 ps))
 

bpVariable ps ==
    bpParenthesized(ps,function bpBoundVariablelist) and
       bpPush(ps,bfTupleIf bpPop1 ps)
         or bpBracketConstruct(ps,function bpPatternL)
                or bpName ps or bpConstTok ps
 
bpAssignVariable ps ==
      bpBracketConstruct(ps,function bpPatternL) or bpAssignLHS ps
 
bpAssignLHS ps ==
  not bpName ps => false
  bpEqKey(ps,"COLON") =>          -- variable declaration
    bpRequire(ps,function bpApplication)
    bpPush(ps,bfLocal(bpPop2 ps,bpPop1 ps))
  bpArgumentList ps and 
    (bpEqPeek(ps,"DOT")
      or (bpEqPeek(ps,"BEC") and bpPush(ps,bfPlace bpPop1 ps)) 
        or bpTrap ps)
  bpEqKey(ps,"DOT") =>            -- field path
    bpList(ps,function bpPrimary,"DOT") and 
      bpChecknull ps and
        bpPush(ps,bfTuple([bpPop2 ps,:bpPop1 ps]))
  true

bpChecknull ps ==
  a := bpPop1 ps
  a = nil => bpTrap ps
  bpPush(ps,a)

bpStruct ps ==
   bpEqKey(ps,"STRUCTURE") and
      bpRequire(ps,function bpName) and
        (bpEqKey(ps,"DEF") or bpTrap ps) and
           (bpRecord ps or bpTypeList ps) and
             bpPush(ps,%Structure(bpPop2 ps,bpPop1 ps))
 
++ Record:
++   "Record" "(" FieldList ")"
bpRecord ps ==
  s := bpState ps
  bpName ps and bpPop1 ps is "Record" =>
    (bpParenthesized(ps,function bpFieldList) or bpTrap ps) and
      bpGlobalAccessors ps and
        bpPush(ps,%Record(bfUntuple bpPop2 ps,bpPop1 ps))
  bpRestore(ps,s)
  false

++ FieldList:
++    Signature
++    Signature , FieldList
bpFieldList ps ==
  bpTuple(ps,function bpSignature)

bpGlobalAccessors ps ==
  bpEqKey(ps,"WITH") =>
    bpPileBracketed(ps,function bpAccessorDefinitionList) or bpTrap ps
  bpPush(ps,nil)

bpAccessorDefinitionList ps ==
  bpListAndRecover(ps,function bpAccessorDefinition)

++ AccessorDefinition:
++   Name DEF FieldSection
bpAccessorDefinition ps ==
  bpRequire(ps,function bpName) and
    (bpEqKey(ps,"DEF") or bpTrap ps) and
       bpRequire(ps,function bpFieldSection) and
         bpPush(ps,%AccessorDef(bpPop2 ps,bpPop1 ps))

++ FieldSection:
++    "(" DOT Name ")"
bpFieldSection ps ==
  bpParenthesized(ps,function bpSelectField)

bpSelectField ps ==
  bpEqKey(ps,"DOT") and bpName ps

bpTypeList ps == 
  bpPileBracketed(ps,function bpTypeItemList)
    or bpTypeItem ps and bpPush(ps,[bpPop1 ps])

bpTypeItem ps ==
  bpTerm(ps,function bpIdList)
 
bpTypeItemList ps ==  
  bpListAndRecover(ps,function bpTypeItem)
 
bpTerm(ps,idListParser) ==
  bpRequire(ps,function bpName) and
    ((bpParenthesized(ps,idListParser) and
      bpPush(ps,bfNameArgs(bpPop2 ps,bpPop1 ps)))
	or bpName ps and bpPush(ps,bfNameArgs(bpPop2 ps,bpPop1 ps)))
	 or bpPush(ps,bfNameOnly bpPop1 ps)
 
bpIdList ps == 
  bpTuple(ps,function bpName)
 
bpCase ps ==
  bpEqKey(ps,"CASE") and
    bpRequire(ps,function bpWhere) and
       (bpEqKey(ps,"OF") or bpMissing(ps,"OF")) and
	     bpPiledCaseItems ps
 
bpPiledCaseItems ps ==
   bpPileBracketed(ps,function bpCaseItemList) and
       bpPush(ps,bfCase(bpPop2 ps,bpPop1 ps))

bpCaseItemList ps ==
   bpListAndRecover(ps,function bpCaseItem)

bpCasePatternVar ps ==
  bpName ps or bpDot ps

bpCasePatternVarList ps ==
  bpTuple(ps,function bpCasePatternVar)
 
bpCaseItem ps ==
    (bpTerm(ps,function bpCasePatternVarList) or bpTrap ps) and
       (bpEqKey(ps,"EXIT") or bpTrap ps) and
         bpRequire(ps,function bpWhere) and
            bpPush(ps,bfCaseItem(bpPop2 ps,bpPop1 ps))


++ Main entry point into the parser module.
bpOutItem ps ==
  $op: local := nil
  $GenVarCounter: local := 0
  try bpRequire(ps,function bpComma)
  catch(e: BootSpecificError) =>
    bpSpecificErrorHere(ps,e)
    bpTrap ps
  b := bpPop1 ps
  t :=
    b is ["+LINE",:.] => [ b ]
    b is ["L%T",l,r] and symbol? l => 
      $InteractiveMode => [["SETQ",l,r]]
      [["DEFPARAMETER",l,r]]
    translateToplevel(b,false)
  bpPush(ps,t)