examples/OCaml-Kaleidoscope/Chapter4/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 let rec parse_primary = parser
  17   (* numberexpr ::= number *)
  18   | [< 'Token.Number n >] -> Ast.Number n
  19
  20   (* parenexpr ::= '(' expression ')' *)
  21   | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
  22
  23   (* identifierexpr
  24    *   ::= identifier
  25    *   ::= identifier '(' argumentexpr ')' *)
  26   | [< 'Token.Ident id; stream >] ->
  27       let rec parse_args accumulator = parser
  28         | [< e=parse_expr; stream >] ->
  29             begin parser
  30               | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
  31               | [< >] -> e :: accumulator
  32             end stream
  33         | [< >] -> accumulator
  34       in
  35       let rec parse_ident id = parser
  36         (* Call. *)
  37         | [< 'Token.Kwd '(';
  38              args=parse_args [];
  39              'Token.Kwd ')' ?? "expected ')'">] ->
  40             Ast.Call (id, Array.of_list (List.rev args))
  41
  42         (* Simple variable ref. *)
  43         | [< >] -> Ast.Variable id
  44       in
  45       parse_ident id stream
  46
  47   | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
  48
  49 (* binoprhs
  50  *   ::= ('+' primary)* *)
  51 and parse_bin_rhs expr_prec lhs stream =
  52   match Stream.peek stream with
  53   (* If this is a binop, find its precedence. *)
  54   | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
  55       let token_prec = precedence c in
  56
  57       (* If this is a binop that binds at least as tightly as the current binop,
  58        * consume it, otherwise we are done. *)
  59       if token_prec < expr_prec then lhs else begin
  60         (* Eat the binop. *)
  61         Stream.junk stream;
  62
  63         (* Parse the primary expression after the binary operator. *)
  64         let rhs = parse_primary stream in
  65
  66         (* Okay, we know this is a binop. *)
  67         let rhs =
  68           match Stream.peek stream with
  69           | Some (Token.Kwd c2) ->
  70               (* If BinOp binds less tightly with rhs than the operator after
  71                * rhs, let the pending operator take rhs as its lhs. *)
  72               let next_prec = precedence c2 in
  73               if token_prec < next_prec
  74               then parse_bin_rhs (token_prec + 1) rhs stream
  75               else rhs
  76           | _ -> rhs
  77         in
  78
  79         (* Merge lhs/rhs. *)
  80         let lhs = Ast.Binary (c, lhs, rhs) in
  81         parse_bin_rhs expr_prec lhs stream
  82       end
  83   | _ -> lhs
  84
  85 (* expression
  86  *   ::= primary binoprhs *)
  87 and parse_expr = parser
  88   | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
  89
  90 (* prototype
  91  *   ::= id '(' id* ')' *)
  92 let parse_prototype =
  93   let rec parse_args accumulator = parser
  94     | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
  95     | [< >] -> accumulator
  96   in
  97
  98   parser
  99   | [< 'Token.Ident id;
 100        'Token.Kwd '(' ?? "expected '(' in prototype";
 101        args=parse_args [];
 102        'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
 103       (* success. *)
 104       Ast.Prototype (id, Array.of_list (List.rev args))
 105
 106   | [< >] ->
 107       raise (Stream.Error "expected function name in prototype")
 108
 109 (* definition ::= 'def' prototype expression *)
 110 let parse_definition = parser
 111   | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
 112       Ast.Function (p, e)
 113
 114 (* toplevelexpr ::= expression *)
 115 let parse_toplevel = parser
 116   | [< e=parse_expr >] ->
 117       (* Make an anonymous proto. *)
 118       Ast.Function (Ast.Prototype ("", [||]), e)
 119
 120 (*  external ::= 'extern' prototype *)
 121 let parse_extern = parser
 122   | [< 'Token.Extern; e=parse_prototype >] -> e