PreviousUpNext

15.4.436  src/lib/compiler/back/low/tools/precedence-parser/precedence-parser.pkg

## precedence-parser.pkg
#
#  A really stupid but (hopefully) working precedence parser 
#
#  --Allen Leung (leunga@cs.nyu.edu)

# Compiled by:
#     src/lib/compiler/back/low/tools/precedence-parser.lib



###                         "It's fine to work on any problem,
###                          so long as it generates interesting
###                          mathematics along the way -- even if you
###                          don't solve it at the end of the day."
###
###                                       -- Andrew Wiles



api Precedence_Parser {

    Precedence_Stack;

    Fixity = INFIX  Int 
               | INFIXR  Int 
               | NONFIX; 

    Token X  = ID   String
                  | EXP  X;

   exception PRECEDENCE_ERROR;

    empty:  Precedence_Stack; 
    declare:  (Precedence_Stack, String, Fixity) -> Precedence_Stack;
    parse:    { stack:          Precedence_Stack,
                   apply:            (X, X) -> X,
                   tuple:          List(X) -> X,
                   id:             String -> X,
                   error:          String -> Void,
                   to_string:       X -> String,
                   kind:           String
                 } -> List( Token(X) ) -> X;
};



package   precedence_parser
: (weak)  Precedence_Parser                             # Precedence_Parser     is from   src/lib/compiler/back/low/tools/precedence-parser/precedence-parser.pkg
{
    Fixity = INFIX  Int 
           | INFIXR  Int 
           | NONFIX; 

    Token X  = ID  String
             | EXP  X;

    Precedence_Stack = List( (String, Fixity) ); 

    empty = [];

    fun declare (stack, id, fixity)
        =
        (id, fixity) ! stack;

    exception PRECEDENCE_ERROR;

    fun parse { stack, tuple, apply, id, to_string, error, kind } tokens
        =
        {   fun fixity x
                =
                f stack
                where
                    fun f [] => NONFIX;
                        f ((y, fix) ! sss) => if (x == y ) fix; else f sss;fi;
                    end;
                end;

            toks = map  fn ID x  => (id x, fixity x);
                           EXP e => (e, NONFIX);
                        end

                        tokens;

            fun err msg
                =
                {   error ( msg + " in " + kind + ": "
                            +
                            (list::fold_backward
                                fn ((x, _), "") =>  to_string x;
                                   ((x, _),  s) =>  to_string x + " " + s;
                                end
                                ""
                                toks
                            )
                          );
                   raise exception PRECEDENCE_ERROR;
                };

            fun err' (msg, x)
                =
                err (msg + " " + to_string x);

            # Parse with precedence. 
            #
            fun scan (p, tokens)
                =
                case tokens
                  
                     (f, NONFIX) ! (x, NONFIX) ! rest
                         =>
                         scan (p, (apply (f, x), NONFIX) ! rest); #  Application 

                     [(x, NONFIX)]
                         =>
                         (x, []);

                     (x, INFIX _) ! _
                         =>
                         err'("dangling infix symbol", x);

                     (x, INFIXR _) ! _
                         =>
                         err'("dangling infixr symbol", x);

                     (left, NONFIX) ! (rest as (f, INFIX q) ! rest')
                         =>
                         if   (p >= q)
                              
                              (left, rest);
                         else
                              my (right, rest) = scan (q, rest');
                              scan (p, (apply (f, tuple [left, right]), NONFIX) ! rest);
                         fi;

                     (left, NONFIX) ! (rest as (f, INFIXR q) ! rest')
                         =>
                         if   (p > q)
                             
                              (left, rest);
                         else
                              my (right, rest) = scan (q, rest');
                              scan (p, (apply (f, tuple [left, right]), NONFIX) ! rest);
                         fi;

                     _   =>
                         err("parse error");
                esac;

            fun scan_all [(x, INFIX  _)] =>  x;
                scan_all [(x, INFIXR _)] =>  x;
                scan_all tokens          =>  #1 (scan(-1, tokens));
            end;

            scan_all toks;
        };
};


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext