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 +
       ExpErr String

and type Dec =
       VarDec String + Decs Dec Dec +
       DecErr String

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

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


  and Expression =                                       -- parse an Expression

      let rec
          OprSeq NonTerm separators inp =
             let rec T, rest = NonTerm inp         -- at least one Non-Terminal
             and s T1 inp =
                   if mem (hd inp) separators then  -- optional sep NonTerm ...
                      let T2, rest2 = NonTerm (tl inp)
                      in  case T2 in
                          ExpErr _: T2, rest2 ||
                          _       : s (BExp (hd inp) T1 T2) rest2      -- more?
                          end
                   else T1, inp
             in case T in
                ExpErr _: T, rest ||
                _       : s T rest
                end

      and opd (openSy . rest) =
             let T,(s . rest2) = Expression rest
             in  if s=closeSy then T, rest2
                 else ExpErr "missing )", (s.rest2)  ||

          opd (IdentSy x . rest) = Ident x, rest ||

          opd (NumSy n . rest)   = Num n, rest   ||

          opd (s . rest) =
             if mem s [plusSy; minusSy; notSy] then  -- Unary Operators
                let T, rest2 = opd rest
                in case T in
                   ExpErr _: T, rest ||
                   _       : UExp s T, rest2
                   end
             else ExpErr "bad operand", (s.rest)

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

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


  and Declarations inp =                                  -- >=1 Declaration ;

      let Declaration (varSy . IdentSy x . rest) = VarDec x, rest ||
          Declaration r            = DecErr "bad Decln", r

      in case Declaration inp in
         DecErr m, r    : DecErr m, r ||
         D1, semiSy.rest: case Declarations rest in
                          DecErr m, r: D1, rest ||
                          D2, rest   : Decs D1 D2, rest
                          end ||
         D1, r          : DecErr "Decs, no ;", r
         end                                             -- end of Declarations


  and Command inp =                                          -- parse a Command

     let rec
         ifCommand inp =
         case Expression inp in
         ExpErr m, r    : CmdErr("if "@m),r ||
         E, thenSy.rest1:                                               -- then
            case Commands rest1 in
            CmdErr m, r        : CmdErr m, r ||
            Ctrue, elseSy.rest2:                                        -- else
               case Commands rest2 in
               CmdErr m, r       : CmdErr m, r ||
               Cfalse, fiSy.rest3: IfCmd E Ctrue Cfalse, rest3 ||         -- fi
               _, r              : CmdErr "no fi", r
               end  ||
            _, r               : CmdErr "no else", r
            end  ||
         _, r           : CmdErr "no then", r
         end

     and whileCommand inp =
         case Expression inp in
         ExpErr m, r : CmdErr("while "@m), r ||
         E, doSy.rest: case Commands rest in                              -- do
                       CmdErr m, r      : CmdErr("do "@m), r ||
                       Body, (odSy.rest): WhileCmd E Body, rest ||        -- od
                       _, r             : CmdErr "no od", r
                       end  ||
         _, r        : CmdErr "no do", r
         end

     and blockCommand inp =
         case Declarations inp in
         DecErr m, r: case Commands inp in                    -- begin Cmds end
                      C, endSy.rest: C, rest ||                          -- end
                      _, r         : CmdErr "no end", r
                      end  ||
         D, r       : case Commands r in                -- begin Decs; Cmds end
                      CmdErr m, r  : CmdErr m, r ||
                      C, endSy.rest: Block D C, rest ||                  -- end
                      _, r         : CmdErr "no end", r
                      end
         end

     and assignment inp =                                         -- Exp := Exp
         case Expression inp in
         ExpErr m, r        : CmdErr(m@":="), r ||
         LHS, becomesSy.rest: case Expression rest in
                              ExpErr m, rest2: CmdErr(":="@m), rest2   ||
                              RHS, rest2     : Assign LHS RHS, rest2
                              end  ||
         _, r               : CmdErr "no :=", r
         end

      and Commands inp =                                          -- cmd1; cmd2
          case Command inp in
          CmdErr m, r      : CmdErr m, r ||
          C1, semiSy . rest: case Commands rest in
                             CmdErr m, r : CmdErr m, r ||
                             C2, rest2   : Cmds C1 C2, rest2     -- right assoc
                             end ||
          C1, r            : C1, r
          end

      in case inp in
         ifSy.   rest: ifCommand    rest ||
         whileSy.rest: whileCommand rest ||
         beginSy.rest: blockCommand rest ||
         writeSy.rest: case Expression rest in
                       ExpErr m, r: CmdErr("write "@m), r ||
                       E, r       : Write E, r
                       end  ||
         _           : assignment inp
         end                                                  -- end of Command

  in  case Command (choplist lexical inp) in
      CmdErr m, _: CmdErr m ||               -- syntax error
      T, [eofSy] : T        ||               -- syntax ok
      _, _       : CmdErr "junk at eof"      -- not all parsed
      end                                                       -- end of parse


--\fB Simple Recursive Descent Parser in LML. \fP
-- L.Allison, Department of Computer Science, Monash University, Australia