let rec
    type symbol =                                               -- lexical type
       IdentSy String  +  NumSy Int +
       plusSy + minusSy + timesSy + divSy +
       eqSy + neSy + ltSy + leSy + gtSy + geSy +
       notSy + andSy + orSy +
       becomesSy + openSy + closeSy + semiSy +
       varSy +
       ifSy + thenSy + elseSy + fiSy +
       whileSy + doSy + odSy +
       beginSy + endSy +
       writeSy +
       eofSy   + symbolErr String

-------------------------------------------------------------------------------

and type Exp =
       Ident String + Num Int +                              -- syntactic types
       UExp symbol Exp + BExp symbol Exp Exp

and type Dec =
       VarDec String + Decs Dec Dec

and type Cmd =
       Assign   Exp Exp     +
       IfCmd    Exp Cmd Cmd +
       WhileCmd Exp Cmd     +
       Cmds     Cmd Cmd     +
       Block    Dec Cmd     +
       Write    Exp

and type PTree = exp Exp + dec Dec + cmd Cmd + PError String     -- Parse Trees
               + MarkStack

-------------------------------------------------------------------------------

in let parse inp =                                           -- parse a program
  let rec
      lexical "" = eofSy, "" ||                              -- lexical routine

      lexical s  =
         if mem (hd s) [' '; '\n'; '\t'] then lexical (tl s)
         else case s in
              ':' . '=' . R  :  becomesSy,R ||
              '<' . '>' . R  :  neSy,     R ||
              '<' . '=' . R  :  leSy,     R ||
              '>' . '=' . R  :  geSy,     R ||
              s: let w,r = takeword s
                 in if isdigit(hd w) then NumSy(stoi w), r
                    else assoc w
                     (if isalpha(hd w) then [
                       ("if",   ifSy);                              -- keywords
                       ("then", thenSy); ("else", elseSy);
                       ("fi",   fiSy);
                       ("while",whileSy); ("do",   doSy); ("od",   odSy);
                       ("begin",beginSy); ("end",  endSy);
                       ("write",writeSy);
                       ("var",  varSy);
                       ("not", notSy); ("and", andSy); ("or",  orSy);
                       (w, IdentSy w)  ]
                      else [
                       ("(", openSy); (")", closeSy);
                       ("=", eqSy);   (";", semiSy);
                       ("+", plusSy); ("-", minusSy);
                       ("*", timesSy);("/", divSy);
                       ("<", ltSy);   (">", gtSy);
                       (w, symbolErr w) ]
                     ), r
              end

-------------------------------------------------------------------------------

-- type Cont = (list PTree) -> (list symbol) -> PTree
--             parse stack     input string     answer
--
-- type Parser = Cont -> Cont

                                                            -- utility routines
and finish [cmd T] [eofSy] = cmd T  ||     --   finish :Cont    finish parsing
    finish (PError m. _) _ = PError m  ||
    finish  _  _           = PError " junk at end of parsing "

and literal _       sym c T (s.rest)&(sym=s) = c T rest  ||
    literal message _   _ _ _                = PError (" missing " @ message)

and cat (Parser1.Ps) c = Parser1 (cat Ps c) ||     -- cat (List Parser) :Parser
    cat [] c = c

 -- either (List (symbol#Parser)) :Parser    an LL(1) choice operator
and either [( _  ,Parser)]     c T inp = Parser c T inp  ||  -- last must go
    either ((sym1,Parser1).Ps) c T inp&(hd inp=sym1) = Parser1 c T inp  ||
    either (    _         .Ps) c T inp               = either Ps c T inp

and OprSeq ops NonTerm c =     -- eg. x+y+z    OprSeq syms Parser :Parser
       let rec opNT T (s.rest)&(mem s ops) = NonTerm (build s) T rest ||
               opNT T inp                  = c T inp
       and     build op (exp right.exp left.other) =
                  opNT (exp(BExp op left right).other)
       in  NonTerm opNT

-------------------------------------------------------------------------------

in let rec                                                     -- syntax proper
    Expression =                                                  -- Expression
    let rec
        opd c T (IdentSy x . rest) = c (exp(Ident x). T) rest  ||
        opd c T (NumSy   n . rest) = c (exp(Num   n). T) rest  ||
        opd c T (sy . rest)&(mem sy [minusSy; plusSy; notSy]) =
           let c2 (exp e . T) = c (exp(UExp sy e). T)
           in  factor c2 T rest  ||
        opd c T _ = PError " bad operand "

    and subexp = cat [literal "(" openSy; Expression; literal ")" closeSy]
    and factor = either [(openSy, subexp); (IdentSy "dontcare", opd)]

    and term      = OprSeq [timesSy; divSy] factor
    and arithExp  = OprSeq [plusSy; minusSy] term
    and relExp    = OprSeq [eqSy; neSy; ltSy; leSy; gtSy; geSy] arithExp

    in OprSeq [andSy; orSy] relExp                         -- end of Expression

-------------------------------------------------------------------------------

and Declarations dc =   -- [ dec; dec; ... ]                       Declarations
    let rec
        Declaration c T (varSy. IdentSy x. rest) = c (dec(VarDec x).T) rest ||
        Declaration c T inp = dc T inp
    and seq = cat [literal ";" semiSy; Declaration] group
    and group (dec D2. dec D1. T) = seq (dec(Decs D1 D2). T)
    in  Declaration seq                                  -- end of Declarations

-------------------------------------------------------------------------------

and Command =                                                        -- Command
    let rec
        ifCommand c =
           let c2 (cmd gf.cmd gt.exp be. T) = c (cmd(IfCmd be gt gf).T)
           in  cat [literal "if"   ifSy;   Expression;
                    literal "then" thenSy; Commands;
                    literal "else" elseSy; Commands;
                    literal "fi"   fiSy] c2

    and whileCommand c =
        let c2 (cmd g . exp be . T) = c (cmd(WhileCmd be g) . T)
        in  cat [literal "while" whileSy; Expression;
                 literal "do"    doSy;    Commands;
                 literal "od"    odSy] c2

    and blockCommand c T =
       let c2 (cmd g. dec d. MarkStack. T) = c (cmd(Block d g). T) ||  -- decs
           c2 (cmd g. MarkStack. T) = c (cmd g. T)                  -- no decs
       in  cat [literal "begin" beginSy; Declarations; Commands;
                literal "end" endSy] c2
               (MarkStack. T)      -- avoid capture of any outer declarations!

    and assignment c =
       let c2 (exp Rhs. exp Lhs. T) = c (cmd(Assign Lhs Rhs).T)
       in  cat [Expression; literal ":=" becomesSy; Expression] c2

    and writeCommand c =
       let c2 (exp e.T) = c (cmd(Write e).T)
       in  cat [literal "write" writeSy; Expression] c2

    and Commands c =
        let rec seq T (semiSy.rest) = Commands group T rest ||
                seq T inp = c T inp
        and     group (cmd C2. cmd C1. T) = c (cmd(Cmds C1 C2). T)
        in  Command seq

    in either [ (ifSy,    ifCommand);
                (whileSy, whileCommand);
                (beginSy, blockCommand);
                (writeSy, writeCommand);
                (IdentSy "dontcare", assignment)]             -- end of Command

-------------------------------------------------------------------------------

in Command finish nil (choplist lexical inp)                    -- end of parse


-- see L.Allison. Some Applications of Continuations.
--     Computer Jrnl 31(1) 9-11  1988

--\fB Continuation Based Parser. \fP
-- L.Allison, Department of Computer Science, Monash University, Australia