Home | History | Annotate | Download | only in Chapter5 
      1 (*===---------------------------------------------------------------------===
      2  * Parser
      3  *===---------------------------------------------------------------------===*)
      4 
      5 (* binop_precedence - This holds the precedence for each binary operator that is
      6  * defined *)
      7 let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10
      8 
      9 (* precedence - Get the precedence of the pending binary operator token. *)
     10 let precedence c = try Hashtbl.find binop_precedence c with Not_found -> -1
     11 
     12 (* primary
     13  *   ::= identifier
     14  *   ::= numberexpr
     15  *   ::= parenexpr
     16  *   ::= ifexpr
     17  *   ::= forexpr *)
     18 let rec parse_primary = parser
     19   (* numberexpr ::= number *)
     20   | [< 'Token.Number n >] -> Ast.Number n
     21 
     22   (* parenexpr ::= '(' expression ')' *)
     23   | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
     24 
     25   (* identifierexpr
     26    *   ::= identifier
     27    *   ::= identifier '(' argumentexpr ')' *)
     28   | [< 'Token.Ident id; stream >] ->
     29       let rec parse_args accumulator = parser
     30         | [< e=parse_expr; stream >] ->
     31             begin parser
     32               | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
     33               | [< >] -> e :: accumulator
     34             end stream
     35         | [< >] -> accumulator
     36       in
     37       let rec parse_ident id = parser
     38         (* Call. *)
     39         | [< 'Token.Kwd '(';
     40              args=parse_args [];
     41              'Token.Kwd ')' ?? "expected ')'">] ->
     42             Ast.Call (id, Array.of_list (List.rev args))
     43 
     44         (* Simple variable ref. *)
     45         | [< >] -> Ast.Variable id
     46       in
     47       parse_ident id stream
     48 
     49   (* ifexpr ::= 'if' expr 'then' expr 'else' expr *)
     50   | [< 'Token.If; c=parse_expr;
     51        'Token.Then ?? "expected 'then'"; t=parse_expr;
     52        'Token.Else ?? "expected 'else'"; e=parse_expr >] ->
     53       Ast.If (c, t, e)
     54 
     55   (* forexpr
     56         ::= 'for' identifier '=' expr ',' expr (',' expr)? 'in' expression *)
     57   | [< 'Token.For;
     58        'Token.Ident id ?? "expected identifier after for";
     59        'Token.Kwd '=' ?? "expected '=' after for";
     60        stream >] ->
     61       begin parser
     62         | [<
     63              start=parse_expr;
     64              'Token.Kwd ',' ?? "expected ',' after for";
     65              end_=parse_expr;
     66              stream >] ->
     67             let step =
     68               begin parser
     69               | [< 'Token.Kwd ','; step=parse_expr >] -> Some step
     70               | [< >] -> None
     71               end stream
     72             in
     73             begin parser
     74             | [< 'Token.In; body=parse_expr >] ->
     75                 Ast.For (id, start, end_, step, body)
     76             | [< >] ->
     77                 raise (Stream.Error "expected 'in' after for")
     78             end stream
     79         | [< >] ->
     80             raise (Stream.Error "expected '=' after for")
     81       end stream
     82 
     83   | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
     84 
     85 (* binoprhs
     86  *   ::= ('+' primary)* *)
     87 and parse_bin_rhs expr_prec lhs stream =
     88   match Stream.peek stream with
     89   (* If this is a binop, find its precedence. *)
     90   | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
     91       let token_prec = precedence c in
     92 
     93       (* If this is a binop that binds at least as tightly as the current binop,
     94        * consume it, otherwise we are done. *)
     95       if token_prec < expr_prec then lhs else begin
     96         (* Eat the binop. *)
     97         Stream.junk stream;
     98 
     99         (* Parse the primary expression after the binary operator. *)
    100         let rhs = parse_primary stream in
    101 
    102         (* Okay, we know this is a binop. *)
    103         let rhs =
    104           match Stream.peek stream with
    105           | Some (Token.Kwd c2) ->
    106               (* If BinOp binds less tightly with rhs than the operator after
    107                * rhs, let the pending operator take rhs as its lhs. *)
    108               let next_prec = precedence c2 in
    109               if token_prec < next_prec
    110               then parse_bin_rhs (token_prec + 1) rhs stream
    111               else rhs
    112           | _ -> rhs
    113         in
    114 
    115         (* Merge lhs/rhs. *)
    116         let lhs = Ast.Binary (c, lhs, rhs) in
    117         parse_bin_rhs expr_prec lhs stream
    118       end
    119   | _ -> lhs
    120 
    121 (* expression
    122  *   ::= primary binoprhs *)
    123 and parse_expr = parser
    124   | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
    125 
    126 (* prototype
    127  *   ::= id '(' id* ')' *)
    128 let parse_prototype =
    129   let rec parse_args accumulator = parser
    130     | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
    131     | [< >] -> accumulator
    132   in
    133 
    134   parser
    135   | [< 'Token.Ident id;
    136        'Token.Kwd '(' ?? "expected '(' in prototype";
    137        args=parse_args [];
    138        'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
    139       (* success. *)
    140       Ast.Prototype (id, Array.of_list (List.rev args))
    141 
    142   | [< >] ->
    143       raise (Stream.Error "expected function name in prototype")
    144 
    145 (* definition ::= 'def' prototype expression *)
    146 let parse_definition = parser
    147   | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
    148       Ast.Function (p, e)
    149 
    150 (* toplevelexpr ::= expression *)
    151 let parse_toplevel = parser
    152   | [< e=parse_expr >] ->
    153       (* Make an anonymous proto. *)
    154       Ast.Function (Ast.Prototype ("", [||]), e)
    155 
    156 (*  external ::= 'extern' prototype *)
    157 let parse_extern = parser
    158   | [< 'Token.Extern; e=parse_prototype >] -> e
    159