examples/OCaml-Kaleidoscope/Chapter6/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 (* unary
  86  *   ::= primary
  87  *   ::= '!' unary *)
  88 and parse_unary = parser
  89   (* If this is a unary operator, read it. *)
  90   | [< 'Token.Kwd op when op != '(' && op != ')'; operand=parse_expr >] ->
  91       Ast.Unary (op, operand)
  92
  93   (* If the current token is not an operator, it must be a primary expr. *)
  94   | [< stream >] -> parse_primary stream
  95
  96 (* binoprhs
  97  *   ::= ('+' primary)* *)
  98 and parse_bin_rhs expr_prec lhs stream =
  99   match Stream.peek stream with
 100   (* If this is a binop, find its precedence. *)
 101   | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
 102       let token_prec = precedence c in
 103
 104       (* If this is a binop that binds at least as tightly as the current binop,
 105        * consume it, otherwise we are done. *)
 106       if token_prec < expr_prec then lhs else begin
 107         (* Eat the binop. *)
 108         Stream.junk stream;
 109
 110         (* Parse the unary expression after the binary operator. *)
 111         let rhs = parse_unary stream in
 112
 113         (* Okay, we know this is a binop. *)
 114         let rhs =
 115           match Stream.peek stream with
 116           | Some (Token.Kwd c2) ->
 117               (* If BinOp binds less tightly with rhs than the operator after
 118                * rhs, let the pending operator take rhs as its lhs. *)
 119               let next_prec = precedence c2 in
 120               if token_prec < next_prec
 121               then parse_bin_rhs (token_prec + 1) rhs stream
 122               else rhs
 123           | _ -> rhs
 124         in
 125
 126         (* Merge lhs/rhs. *)
 127         let lhs = Ast.Binary (c, lhs, rhs) in
 128         parse_bin_rhs expr_prec lhs stream
 129       end
 130   | _ -> lhs
 131
 132 (* expression
 133  *   ::= primary binoprhs *)
 134 and parse_expr = parser
 135   | [< lhs=parse_unary; stream >] -> parse_bin_rhs 0 lhs stream
 136
 137 (* prototype
 138  *   ::= id '(' id* ')'
 139  *   ::= binary LETTER number? (id, id)
 140  *   ::= unary LETTER number? (id) *)
 141 let parse_prototype =
 142   let rec parse_args accumulator = parser
 143     | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
 144     | [< >] -> accumulator
 145   in
 146   let parse_operator = parser
 147     | [< 'Token.Unary >] -> "unary", 1
 148     | [< 'Token.Binary >] -> "binary", 2
 149   in
 150   let parse_binary_precedence = parser
 151     | [< 'Token.Number n >] -> int_of_float n
 152     | [< >] -> 30
 153   in
 154   parser
 155   | [< 'Token.Ident id;
 156        'Token.Kwd '(' ?? "expected '(' in prototype";
 157        args=parse_args [];
 158        'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
 159       (* success. *)
 160       Ast.Prototype (id, Array.of_list (List.rev args))
 161   | [< (prefix, kind)=parse_operator;
 162        'Token.Kwd op ?? "expected an operator";
 163        (* Read the precedence if present. *)
 164        binary_precedence=parse_binary_precedence;
 165        'Token.Kwd '(' ?? "expected '(' in prototype";
 166         args=parse_args [];
 167        'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
 168       let name = prefix ^ (String.make 1 op) in
 169       let args = Array.of_list (List.rev args) in
 170
 171       (* Verify right number of arguments for operator. *)
 172       if Array.length args != kind
 173       then raise (Stream.Error "invalid number of operands for operator")
 174       else
 175         if kind == 1 then
 176           Ast.Prototype (name, args)
 177         else
 178           Ast.BinOpPrototype (name, args, binary_precedence)
 179   | [< >] ->
 180       raise (Stream.Error "expected function name in prototype")
 181
 182 (* definition ::= 'def' prototype expression *)
 183 let parse_definition = parser
 184   | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
 185       Ast.Function (p, e)
 186
 187 (* toplevelexpr ::= expression *)
 188 let parse_toplevel = parser
 189   | [< e=parse_expr >] ->
 190       (* Make an anonymous proto. *)
 191       Ast.Function (Ast.Prototype ("", [||]), e)
 192
 193 (*  external ::= 'extern' prototype *)
 194 let parse_extern = parser
 195   | [< 'Token.Extern; e=parse_prototype >] -> e