| (*===---------------------------------------------------------------------=== |
| * Parser |
| *===---------------------------------------------------------------------===*) |
| |
| (* binop_precedence - This holds the precedence for each binary operator that is |
| * defined *) |
| let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10 |
| |
| (* precedence - Get the precedence of the pending binary operator token. *) |
| let precedence c = try Hashtbl.find binop_precedence c with Not_found -> -1 |
| |
| (* primary |
| * ::= identifier |
| * ::= numberexpr |
| * ::= parenexpr |
| * ::= ifexpr |
| * ::= forexpr |
| * ::= varexpr *) |
| let rec parse_primary = parser |
| (* numberexpr ::= number *) |
| | [< 'Token.Number n >] -> Ast.Number n |
| |
| (* parenexpr ::= '(' expression ')' *) |
| | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e |
| |
| (* identifierexpr |
| * ::= identifier |
| * ::= identifier '(' argumentexpr ')' *) |
| | [< 'Token.Ident id; stream >] -> |
| let rec parse_args accumulator = parser |
| | [< e=parse_expr; stream >] -> |
| begin parser |
| | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e |
| | [< >] -> e :: accumulator |
| end stream |
| | [< >] -> accumulator |
| in |
| let rec parse_ident id = parser |
| (* Call. *) |
| | [< 'Token.Kwd '('; |
| args=parse_args []; |
| 'Token.Kwd ')' ?? "expected ')'">] -> |
| Ast.Call (id, Array.of_list (List.rev args)) |
| |
| (* Simple variable ref. *) |
| | [< >] -> Ast.Variable id |
| in |
| parse_ident id stream |
| |
| (* ifexpr ::= 'if' expr 'then' expr 'else' expr *) |
| | [< 'Token.If; c=parse_expr; |
| 'Token.Then ?? "expected 'then'"; t=parse_expr; |
| 'Token.Else ?? "expected 'else'"; e=parse_expr >] -> |
| Ast.If (c, t, e) |
| |
| (* forexpr |
| ::= 'for' identifier '=' expr ',' expr (',' expr)? 'in' expression *) |
| | [< 'Token.For; |
| 'Token.Ident id ?? "expected identifier after for"; |
| 'Token.Kwd '=' ?? "expected '=' after for"; |
| stream >] -> |
| begin parser |
| | [< |
| start=parse_expr; |
| 'Token.Kwd ',' ?? "expected ',' after for"; |
| end_=parse_expr; |
| stream >] -> |
| let step = |
| begin parser |
| | [< 'Token.Kwd ','; step=parse_expr >] -> Some step |
| | [< >] -> None |
| end stream |
| in |
| begin parser |
| | [< 'Token.In; body=parse_expr >] -> |
| Ast.For (id, start, end_, step, body) |
| | [< >] -> |
| raise (Stream.Error "expected 'in' after for") |
| end stream |
| | [< >] -> |
| raise (Stream.Error "expected '=' after for") |
| end stream |
| |
| (* varexpr |
| * ::= 'var' identifier ('=' expression? |
| * (',' identifier ('=' expression)?)* 'in' expression *) |
| | [< 'Token.Var; |
| (* At least one variable name is required. *) |
| 'Token.Ident id ?? "expected identifier after var"; |
| init=parse_var_init; |
| var_names=parse_var_names [(id, init)]; |
| (* At this point, we have to have 'in'. *) |
| 'Token.In ?? "expected 'in' keyword after 'var'"; |
| body=parse_expr >] -> |
| Ast.Var (Array.of_list (List.rev var_names), body) |
| |
| | [< >] -> raise (Stream.Error "unknown token when expecting an expression.") |
| |
| (* unary |
| * ::= primary |
| * ::= '!' unary *) |
| and parse_unary = parser |
| (* If this is a unary operator, read it. *) |
| | [< 'Token.Kwd op when op != '(' && op != ')'; operand=parse_expr >] -> |
| Ast.Unary (op, operand) |
| |
| (* If the current token is not an operator, it must be a primary expr. *) |
| | [< stream >] -> parse_primary stream |
| |
| (* binoprhs |
| * ::= ('+' primary)* *) |
| and parse_bin_rhs expr_prec lhs stream = |
| match Stream.peek stream with |
| (* If this is a binop, find its precedence. *) |
| | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c -> |
| let token_prec = precedence c in |
| |
| (* If this is a binop that binds at least as tightly as the current binop, |
| * consume it, otherwise we are done. *) |
| if token_prec < expr_prec then lhs else begin |
| (* Eat the binop. *) |
| Stream.junk stream; |
| |
| (* Parse the primary expression after the binary operator. *) |
| let rhs = parse_unary stream in |
| |
| (* Okay, we know this is a binop. *) |
| let rhs = |
| match Stream.peek stream with |
| | Some (Token.Kwd c2) -> |
| (* If BinOp binds less tightly with rhs than the operator after |
| * rhs, let the pending operator take rhs as its lhs. *) |
| let next_prec = precedence c2 in |
| if token_prec < next_prec |
| then parse_bin_rhs (token_prec + 1) rhs stream |
| else rhs |
| | _ -> rhs |
| in |
| |
| (* Merge lhs/rhs. *) |
| let lhs = Ast.Binary (c, lhs, rhs) in |
| parse_bin_rhs expr_prec lhs stream |
| end |
| | _ -> lhs |
| |
| and parse_var_init = parser |
| (* read in the optional initializer. *) |
| | [< 'Token.Kwd '='; e=parse_expr >] -> Some e |
| | [< >] -> None |
| |
| and parse_var_names accumulator = parser |
| | [< 'Token.Kwd ','; |
| 'Token.Ident id ?? "expected identifier list after var"; |
| init=parse_var_init; |
| e=parse_var_names ((id, init) :: accumulator) >] -> e |
| | [< >] -> accumulator |
| |
| (* expression |
| * ::= primary binoprhs *) |
| and parse_expr = parser |
| | [< lhs=parse_unary; stream >] -> parse_bin_rhs 0 lhs stream |
| |
| (* prototype |
| * ::= id '(' id* ')' |
| * ::= binary LETTER number? (id, id) |
| * ::= unary LETTER number? (id) *) |
| let parse_prototype = |
| let rec parse_args accumulator = parser |
| | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e |
| | [< >] -> accumulator |
| in |
| let parse_operator = parser |
| | [< 'Token.Unary >] -> "unary", 1 |
| | [< 'Token.Binary >] -> "binary", 2 |
| in |
| let parse_binary_precedence = parser |
| | [< 'Token.Number n >] -> int_of_float n |
| | [< >] -> 30 |
| in |
| parser |
| | [< 'Token.Ident id; |
| 'Token.Kwd '(' ?? "expected '(' in prototype"; |
| args=parse_args []; |
| 'Token.Kwd ')' ?? "expected ')' in prototype" >] -> |
| (* success. *) |
| Ast.Prototype (id, Array.of_list (List.rev args)) |
| | [< (prefix, kind)=parse_operator; |
| 'Token.Kwd op ?? "expected an operator"; |
| (* Read the precedence if present. *) |
| binary_precedence=parse_binary_precedence; |
| 'Token.Kwd '(' ?? "expected '(' in prototype"; |
| args=parse_args []; |
| 'Token.Kwd ')' ?? "expected ')' in prototype" >] -> |
| let name = prefix ^ (String.make 1 op) in |
| let args = Array.of_list (List.rev args) in |
| |
| (* Verify right number of arguments for operator. *) |
| if Array.length args != kind |
| then raise (Stream.Error "invalid number of operands for operator") |
| else |
| if kind == 1 then |
| Ast.Prototype (name, args) |
| else |
| Ast.BinOpPrototype (name, args, binary_precedence) |
| | [< >] -> |
| raise (Stream.Error "expected function name in prototype") |
| |
| (* definition ::= 'def' prototype expression *) |
| let parse_definition = parser |
| | [< 'Token.Def; p=parse_prototype; e=parse_expr >] -> |
| Ast.Function (p, e) |
| |
| (* toplevelexpr ::= expression *) |
| let parse_toplevel = parser |
| | [< e=parse_expr >] -> |
| (* Make an anonymous proto. *) |
| Ast.Function (Ast.Prototype ("", [||]), e) |
| |
| (* external ::= 'extern' prototype *) |
| let parse_extern = parser |
| | [< 'Token.Extern; e=parse_prototype >] -> e |
