examples/OCaml-Kaleidoscope/Chapter5/parser.ml

   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