]>
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 | * ::= 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 | (* binoprhs | |
86 | * ::= ('+' primary)* *) | |
87 | and parse_bin_rhs expr_prec lhs stream = | |
88 | match Stream.peek stream with | |
89 | (* If this is a binop, find its precedence. *) | |
90 | | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c -> | |
91 | let token_prec = precedence c in | |
92 | ||
93 | (* If this is a binop that binds at least as tightly as the current binop, | |
94 | * consume it, otherwise we are done. *) | |
95 | if token_prec < expr_prec then lhs else begin | |
96 | (* Eat the binop. *) | |
97 | Stream.junk stream; | |
98 | ||
99 | (* Parse the primary expression after the binary operator. *) | |
100 | let rhs = parse_primary stream in | |
101 | ||
102 | (* Okay, we know this is a binop. *) | |
103 | let rhs = | |
104 | match Stream.peek stream with | |
105 | | Some (Token.Kwd c2) -> | |
106 | (* If BinOp binds less tightly with rhs than the operator after | |
107 | * rhs, let the pending operator take rhs as its lhs. *) | |
108 | let next_prec = precedence c2 in | |
109 | if token_prec < next_prec | |
110 | then parse_bin_rhs (token_prec + 1) rhs stream | |
111 | else rhs | |
112 | | _ -> rhs | |
113 | in | |
114 | ||
115 | (* Merge lhs/rhs. *) | |
116 | let lhs = Ast.Binary (c, lhs, rhs) in | |
117 | parse_bin_rhs expr_prec lhs stream | |
118 | end | |
119 | | _ -> lhs | |
120 | ||
121 | (* expression | |
122 | * ::= primary binoprhs *) | |
123 | and parse_expr = parser | |
124 | | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream | |
125 | ||
126 | (* prototype | |
127 | * ::= id '(' id* ')' *) | |
128 | let parse_prototype = | |
129 | let rec parse_args accumulator = parser | |
130 | | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e | |
131 | | [< >] -> accumulator | |
132 | in | |
133 | ||
134 | parser | |
135 | | [< 'Token.Ident id; | |
136 | 'Token.Kwd '(' ?? "expected '(' in prototype"; | |
137 | args=parse_args []; | |
138 | 'Token.Kwd ')' ?? "expected ')' in prototype" >] -> | |
139 | (* success. *) | |
140 | Ast.Prototype (id, Array.of_list (List.rev args)) | |
141 | ||
142 | | [< >] -> | |
143 | raise (Stream.Error "expected function name in prototype") | |
144 | ||
145 | (* definition ::= 'def' prototype expression *) | |
146 | let parse_definition = parser | |
147 | | [< 'Token.Def; p=parse_prototype; e=parse_expr >] -> | |
148 | Ast.Function (p, e) | |
149 | ||
150 | (* toplevelexpr ::= expression *) | |
151 | let parse_toplevel = parser | |
152 | | [< e=parse_expr >] -> | |
153 | (* Make an anonymous proto. *) | |
154 | Ast.Function (Ast.Prototype ("", [||]), e) | |
155 | ||
156 | (* external ::= 'extern' prototype *) | |
157 | let parse_extern = parser | |
158 | | [< 'Token.Extern; e=parse_prototype >] -> e |