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 * ::= varexpr *) 19 let rec parse_primary = parser 20 (* numberexpr ::= number *) 21 | [< 'Token.Number n >] -> Ast.Number n 22 23 (* parenexpr ::= '(' expression ')' *) 24 | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e 25 26 (* identifierexpr 27 * ::= identifier 28 * ::= identifier '(' argumentexpr ')' *) 29 | [< 'Token.Ident id; stream >] -> 30 let rec parse_args accumulator = parser 31 | [< e=parse_expr; stream >] -> 32 begin parser 33 | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e 34 | [< >] -> e :: accumulator 35 end stream 36 | [< >] -> accumulator 37 in 38 let rec parse_ident id = parser 39 (* Call. *) 40 | [< 'Token.Kwd '('; 41 args=parse_args []; 42 'Token.Kwd ')' ?? "expected ')'">] -> 43 Ast.Call (id, Array.of_list (List.rev args)) 44 45 (* Simple variable ref. *) 46 | [< >] -> Ast.Variable id 47 in 48 parse_ident id stream 49 50 (* ifexpr ::= 'if' expr 'then' expr 'else' expr *) 51 | [< 'Token.If; c=parse_expr; 52 'Token.Then ?? "expected 'then'"; t=parse_expr; 53 'Token.Else ?? "expected 'else'"; e=parse_expr >] -> 54 Ast.If (c, t, e) 55 56 (* forexpr 57 ::= 'for' identifier '=' expr ',' expr (',' expr)? 'in' expression *) 58 | [< 'Token.For; 59 'Token.Ident id ?? "expected identifier after for"; 60 'Token.Kwd '=' ?? "expected '=' after for"; 61 stream >] -> 62 begin parser 63 | [< 64 start=parse_expr; 65 'Token.Kwd ',' ?? "expected ',' after for"; 66 end_=parse_expr; 67 stream >] -> 68 let step = 69 begin parser 70 | [< 'Token.Kwd ','; step=parse_expr >] -> Some step 71 | [< >] -> None 72 end stream 73 in 74 begin parser 75 | [< 'Token.In; body=parse_expr >] -> 76 Ast.For (id, start, end_, step, body) 77 | [< >] -> 78 raise (Stream.Error "expected 'in' after for") 79 end stream 80 | [< >] -> 81 raise (Stream.Error "expected '=' after for") 82 end stream 83 84 (* varexpr 85 * ::= 'var' identifier ('=' expression? 86 * (',' identifier ('=' expression)?)* 'in' expression *) 87 | [< 'Token.Var; 88 (* At least one variable name is required. *) 89 'Token.Ident id ?? "expected identifier after var"; 90 init=parse_var_init; 91 var_names=parse_var_names [(id, init)]; 92 (* At this point, we have to have 'in'. *) 93 'Token.In ?? "expected 'in' keyword after 'var'"; 94 body=parse_expr >] -> 95 Ast.Var (Array.of_list (List.rev var_names), body) 96 97 | [< >] -> raise (Stream.Error "unknown token when expecting an expression.") 98 99 (* unary 100 * ::= primary 101 * ::= '!' unary *) 102 and parse_unary = parser 103 (* If this is a unary operator, read it. *) 104 | [< 'Token.Kwd op when op != '(' && op != ')'; operand=parse_expr >] -> 105 Ast.Unary (op, operand) 106 107 (* If the current token is not an operator, it must be a primary expr. *) 108 | [< stream >] -> parse_primary stream 109 110 (* binoprhs 111 * ::= ('+' primary)* *) 112 and parse_bin_rhs expr_prec lhs stream = 113 match Stream.peek stream with 114 (* If this is a binop, find its precedence. *) 115 | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c -> 116 let token_prec = precedence c in 117 118 (* If this is a binop that binds at least as tightly as the current binop, 119 * consume it, otherwise we are done. *) 120 if token_prec < expr_prec then lhs else begin 121 (* Eat the binop. *) 122 Stream.junk stream; 123 124 (* Parse the primary expression after the binary operator. *) 125 let rhs = parse_unary stream in 126 127 (* Okay, we know this is a binop. *) 128 let rhs = 129 match Stream.peek stream with 130 | Some (Token.Kwd c2) -> 131 (* If BinOp binds less tightly with rhs than the operator after 132 * rhs, let the pending operator take rhs as its lhs. *) 133 let next_prec = precedence c2 in 134 if token_prec < next_prec 135 then parse_bin_rhs (token_prec + 1) rhs stream 136 else rhs 137 | _ -> rhs 138 in 139 140 (* Merge lhs/rhs. *) 141 let lhs = Ast.Binary (c, lhs, rhs) in 142 parse_bin_rhs expr_prec lhs stream 143 end 144 | _ -> lhs 145 146 and parse_var_init = parser 147 (* read in the optional initializer. *) 148 | [< 'Token.Kwd '='; e=parse_expr >] -> Some e 149 | [< >] -> None 150 151 and parse_var_names accumulator = parser 152 | [< 'Token.Kwd ','; 153 'Token.Ident id ?? "expected identifier list after var"; 154 init=parse_var_init; 155 e=parse_var_names ((id, init) :: accumulator) >] -> e 156 | [< >] -> accumulator 157 158 (* expression 159 * ::= primary binoprhs *) 160 and parse_expr = parser 161 | [< lhs=parse_unary; stream >] -> parse_bin_rhs 0 lhs stream 162 163 (* prototype 164 * ::= id '(' id* ')' 165 * ::= binary LETTER number? (id, id) 166 * ::= unary LETTER number? (id) *) 167 let parse_prototype = 168 let rec parse_args accumulator = parser 169 | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e 170 | [< >] -> accumulator 171 in 172 let parse_operator = parser 173 | [< 'Token.Unary >] -> "unary", 1 174 | [< 'Token.Binary >] -> "binary", 2 175 in 176 let parse_binary_precedence = parser 177 | [< 'Token.Number n >] -> int_of_float n 178 | [< >] -> 30 179 in 180 parser 181 | [< 'Token.Ident id; 182 'Token.Kwd '(' ?? "expected '(' in prototype"; 183 args=parse_args []; 184 'Token.Kwd ')' ?? "expected ')' in prototype" >] -> 185 (* success. *) 186 Ast.Prototype (id, Array.of_list (List.rev args)) 187 | [< (prefix, kind)=parse_operator; 188 'Token.Kwd op ?? "expected an operator"; 189 (* Read the precedence if present. *) 190 binary_precedence=parse_binary_precedence; 191 'Token.Kwd '(' ?? "expected '(' in prototype"; 192 args=parse_args []; 193 'Token.Kwd ')' ?? "expected ')' in prototype" >] -> 194 let name = prefix ^ (String.make 1 op) in 195 let args = Array.of_list (List.rev args) in 196 197 (* Verify right number of arguments for operator. *) 198 if Array.length args != kind 199 then raise (Stream.Error "invalid number of operands for operator") 200 else 201 if kind == 1 then 202 Ast.Prototype (name, args) 203 else 204 Ast.BinOpPrototype (name, args, binary_precedence) 205 | [< >] -> 206 raise (Stream.Error "expected function name in prototype") 207 208 (* definition ::= 'def' prototype expression *) 209 let parse_definition = parser 210 | [< 'Token.Def; p=parse_prototype; e=parse_expr >] -> 211 Ast.Function (p, e) 212 213 (* toplevelexpr ::= expression *) 214 let parse_toplevel = parser 215 | [< e=parse_expr >] -> 216 (* Make an anonymous proto. *) 217 Ast.Function (Ast.Prototype ("", [||]), e) 218 219 (* external ::= 'extern' prototype *) 220 let parse_extern = parser 221 | [< 'Token.Extern; e=parse_prototype >] -> e 222
