]>
Commit | Line | Data |
---|---|---|
223e47cc LB |
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 |