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 196
