/[svn]/parser/parser.ml
ViewVC logotype

Contents of /parser/parser.ml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 61 - (hide annotations)
Tue Jul 10 17:02:11 2007 UTC (5 years, 10 months ago) by abate
File size: 8832 byte(s)
[r2002-10-30 01:39:41 by cvscast] Empty log message

Original author: cvscast
Date: 2002-10-30 01:39:41+00:00
1 abate 4 open Location
2     open Ast
3    
4 abate 38 (* let () = Grammar.error_verbose := true *)
5     let gram = Grammar.gcreate (Lexer.gmake ())
6     let prog = Grammar.Entry.create gram "prog"
7     let expr = Grammar.Entry.create gram "expression"
8     let pat = Grammar.Entry.create gram "type/pattern expression"
9     let regexp = Grammar.Entry.create gram "type/pattern regexp"
10     let const = Grammar.Entry.create gram "scalar constant"
11    
12     let rec multi_prod loc = function
13     | [ x ] -> x
14     | x :: l -> mk loc (Prod (x, multi_prod loc l))
15     | [] -> assert false
16    
17     let rec tuple loc = function
18     | [ x ] -> x
19     | x :: l -> mk (x.loc) (Pair (x, tuple loc l))
20     | [] -> assert false
21    
22     let char = mk noloc (Internal (Types.char Chars.any))
23     let string = Star (Elem char)
24    
25     let cst_nil = mk noloc (Cst (Types.Atom Sequence.nil_atom))
26    
27     let seq_of_string s =
28     let rec aux accu i = if (i = 0) then accu else aux (s.[i-1]::accu) (i-1) in
29     aux [] (String.length s)
30 abate 4
31 abate 18
32 abate 38 let char_list loc s =
33     let s = seq_of_string (Token.eval_string s) in
34     List.map (fun c -> mk loc (Cst (Types.Char (Chars.Unichar.from_char c)))) s
35 abate 18
36    
37 abate 38 EXTEND
38 abate 10 GLOBAL: prog expr pat regexp const;
39 abate 4
40 abate 10 prog: [
41 abate 14 [ l = LIST0 [ p = phrase; ";;" -> mk loc p ]; EOI -> l ]
42 abate 10 ];
43    
44 abate 13 phrase: [
45     [ e = expr -> EvalStatement e
46 abate 43 | "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t)
47     | "debug"; d = debug_directive -> Debug d
48     ]
49 abate 13 ];
50    
51 abate 43 debug_directive: [
52     [ LIDENT "filter"; t = pat; p = pat -> `Filter(t,p)
53     | LIDENT "accept"; p = pat -> `Accept p;
54     | LIDENT "compile"; t = pat; p = LIST1 pat -> `Compile (t,p)
55     ]
56     ];
57    
58 abate 4 expr: [
59     "top" RIGHTA
60     [ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))
61     | "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
62 abate 17 | "transform"; e = SELF; "with"; b = branches ->
63     mk noloc (Op ("flatten", [mk loc (Map (e,b))]))
64 abate 48 | "fun"; (f,a,b) = fun_decl ->
65 abate 4 mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
66     | (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
67     mk loc (Match (e1,[p,e2]))
68 abate 54 | e = expr; ":"; p = pat ->
69     mk loc (Forget (e,p))
70 abate 4 ]
71    
72    
73 abate 15 |
74 abate 51 [ e1 = expr; op = ["+" | "-" | "@"]; e2 = expr -> mk loc (Op (op,[e1;e2]))
75     ]
76 abate 16 |
77 abate 51 [ e1 = expr; op = ["*" | "/"]; e2 = expr -> mk loc (Op (op,[e1;e2]))
78     ]
79 abate 26 |
80 abate 51 [ e = expr; "."; l = [LIDENT | UIDENT] -> mk loc (Dot (e,Types.label l))
81     ]
82 abate 26
83 abate 52 |
84     [ LIDENT "flatten"; e = expr -> mk loc (Op ("flatten",[e]))
85 abate 58 | LIDENT "load_xml"; e = expr -> mk loc (Op ("load_xml",[e]))
86 abate 52 | e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
87     ]
88    
89 abate 4 | "no_appl"
90     [ c = const -> mk loc (Cst c)
91     | "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
92 abate 18 | "["; l = LIST0 seq_elem; e = OPT [ ";"; e = expr -> e ]; "]" ->
93     let e = match e with Some e -> e | None -> cst_nil in
94     let l = List.flatten l in
95 abate 4 tuple loc (l @ [e])
96     | "<"; t = expr_tag_spec; a = expr_attrib_spec; ">"; c = expr ->
97     tuple loc [t;a;c]
98     | "{"; r = [ expr_record_spec | -> mk loc (RecordLitt []) ]; "}" -> r
99 abate 38 | s = STRING ->
100     tuple loc (char_list loc s @ [cst_nil])
101 abate 18 | "!"; t = pat -> mk loc (DebugTyper t)
102 abate 4 | a = LIDENT -> mk loc (Var a)
103     ]
104    
105     ];
106 abate 18
107     seq_elem: [
108 abate 38 [ x = [CHAR | STRING] -> char_list loc x
109 abate 18 | e = expr LEVEL "no_appl" -> [e]
110     ]
111     ];
112 abate 4
113     let_binding: [
114     [ "let"; p = pat; "="; e = expr -> (p,e)
115 abate 54 | "let"; p = pat; ":"; t = pat; "="; e = expr -> (p, mk noloc (Forget (e,t)))
116 abate 48 | "let"; "fun"; (f,a,b) = fun_decl ->
117     let p = match f with
118     | Some x -> mk loc (Capture x)
119     | _ -> failwith "Function name mandatory in let fun declarations"
120     in
121     let abst = { fun_name = f; fun_iface = a; fun_body = b } in
122 abate 4 let e = mk loc (Abstraction abst) in
123 abate 48 (p,e);
124 abate 4 ]
125     ];
126    
127 abate 48 fun_decl: [
128     [ f = OPT LIDENT; "("; a = LIST0 arrow SEP ";"; ")"; b = branches ->
129     (f,a,b)
130     | f = OPT LIDENT; "("; arg = LIDENT; ":"; targ = pat; ")"; ":"; tres = pat ;
131     "="; body = expr ->
132     let b = [mk noloc (Capture arg), body] in
133     let a = [targ,tres] in
134     (f,a,b)
135     ]
136     ];
137    
138 abate 4 arrow: [
139 abate 9 [ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
140 abate 4 ];
141    
142     branches: [
143     [ OPT "|"; l = LIST1 branch SEP "|" ; OPT "end" -> l ]
144     ];
145    
146     branch: [
147 abate 6 [ p = pat LEVEL "no_arrow"; "->"; e = expr -> (p,e) ]
148 abate 4 ];
149    
150    
151     regexp: [
152     [ x = regexp; "|"; y = regexp -> Alt (x,y) ]
153     | [ x = regexp; y = regexp -> Seq (x,y) ]
154     | [ a = LIDENT; "::"; x = regexp -> SeqCapture (a,x) ]
155     | [ x = regexp; "*" -> Star x
156     | x = regexp; "*?" -> WeakStar x
157     | x = regexp; "+" -> Seq (x, Star x)
158     | x = regexp; "+?" -> Seq (x, WeakStar x)
159     | x = regexp; "?" -> Alt (x, Epsilon)
160     | x = regexp; "??" -> Alt (Epsilon, x) ]
161     | [ "("; x = regexp; ")" -> x
162 abate 18 | UIDENT "String" -> string
163 abate 38 | s = CHAR ->
164 abate 18 let s = seq_of_string (Token.eval_string s) in
165     List.fold_right
166     (fun c accu ->
167     let c = Chars.Unichar.from_char c in
168     let c = Chars.atom c in
169     Seq (Elem (mk loc (Internal (Types.char c))), accu))
170     s
171     Epsilon
172 abate 4 | e = pat LEVEL "simple" -> Elem e
173     ]
174     ];
175    
176     pat: [
177     [ x = pat; "where";
178     b = LIST1 [ a = UIDENT; "="; y = pat -> (a,y)] SEP "and"
179     -> mk loc (Recurs (x,b)) ]
180     | RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
181 abate 6 | "no_arrow" [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ]
182 abate 54 | "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y,true))
183     (* | x = pat; ":"; y = pat -> mk loc (And (x,y,false)) *)
184     | x = pat; "-"; y = pat -> mk loc (Diff (x,y)) ]
185 abate 4 |
186     [ "{"; r = record_spec; "}" -> r
187     | LIDENT "_" -> mk loc (Internal Types.any)
188     | a = LIDENT -> mk loc (Capture a)
189     | "("; a = LIDENT; ":="; c = const; ")" -> mk loc (Constant (a,c))
190     | a = UIDENT -> mk loc (PatVar a)
191     | i = INT ; "--"; j = INT ->
192 abate 15 let i = Big_int.big_int_of_string i
193     and j = Big_int.big_int_of_string j in
194 abate 52 mk loc (Internal (Types.interval (Intervals.bounded i j)))
195     | i = INT ->
196     let i = Big_int.big_int_of_string i in
197     mk loc (Internal (Types.interval (Intervals.atom i)))
198     | "*--"; j = INT ->
199     let j = Big_int.big_int_of_string j in
200     mk loc (Internal (Types.interval (Intervals.left j)))
201     | i = INT; "--*" ->
202     let i = Big_int.big_int_of_string i in
203     mk loc (Internal (Types.interval (Intervals.right i)))
204 abate 19 | i = char ->
205     mk loc (Internal (Types.char (Chars.char_class i i)))
206 abate 13 | i = char ; "--"; j = char ->
207 abate 18 mk loc (Internal (Types.char (Chars.char_class i j)))
208 abate 4 | c = const -> mk loc (Internal (Types.constant c))
209     | "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
210     | "["; r = [ r = regexp -> r | -> Epsilon ];
211     q = [ ";"; q = pat -> q
212 abate 18 | -> mk noloc (Internal (Sequence.nil_type)) ];
213 abate 4 "]" -> mk loc (Regexp (r,q))
214     | "<"; t = tag_spec; a = attrib_spec; ">"; c = pat ->
215     multi_prod loc [t;a;c]
216     ]
217    
218     ];
219    
220     record_spec:
221     [ [ r = LIST0 [ l = [LIDENT | UIDENT];
222     o = ["=?" -> true | "=" -> false];
223     x = pat ->
224     mk loc (Record (Types.label l,o,x))
225     ] SEP ";" ->
226     match r with
227 abate 9 | [] -> mk loc (Internal Types.Record.any)
228 abate 54 | h::t -> List.fold_left (fun t1 t2 -> mk loc (And (t1,t2,true))) h t
229 abate 4 ] ];
230    
231 abate 13 char:
232     [
233     [ c = CHAR -> Chars.Unichar.from_char (Token.eval_char c)
234     | "!"; i = INT -> Chars.Unichar.from_int (int_of_string i) ]
235     ];
236    
237    
238 abate 4 const:
239     [
240 abate 15 [ i = INT -> Types.Integer (Big_int.big_int_of_string i)
241 abate 18 | "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.mk_atom a)
242 abate 13 | c = char -> Types.Char c ]
243 abate 4 ];
244    
245     tag_spec:
246     [
247 abate 18 [ LIDENT "_" -> mk loc (Internal (Types.atom (Atoms.any))) ]
248     | [ a = [LIDENT | UIDENT] ->
249     mk loc (Internal (Types.atom (Atoms.atom (Types.mk_atom a)))) ]
250 abate 4 | [ t = pat -> t ]
251     ];
252    
253     attrib_spec:
254     [ [ r = record_spec -> r | "("; t = pat; ")" -> t ] ];
255    
256     expr_record_spec:
257     [ [ r = LIST1
258     [ l = [LIDENT | UIDENT]; "="; x = expr -> (Types.label l,x) ]
259     SEP ";" ->
260     mk loc (RecordLitt r)
261     ] ];
262    
263     expr_tag_spec:
264     [
265     [ a = [LIDENT | UIDENT] ->
266     mk loc (Cst (Types.Atom (Types.mk_atom a))) ]
267     | [ e = expr LEVEL "no_appl" -> e ]
268     ];
269    
270     expr_attrib_spec:
271     [ [ r = expr_record_spec -> r ]
272     | [ e = expr LEVEL "no_appl" -> e
273     | -> mk loc (RecordLitt [])
274     ]
275     ];
276     END
277    
278 abate 61 let pat' = Grammar.Entry.create gram "type/pattern expression"
279     EXTEND GLOBAL: pat pat';
280     pat': [ [ p = pat; EOI -> p ] ];
281     END
282    
283 abate 10 let pat = Grammar.Entry.parse pat
284     let expr = Grammar.Entry.parse expr
285     let prog = Grammar.Entry.parse prog
286    
287     module From_string = struct
288 abate 61 let pat s = Grammar.Entry.parse pat' (Stream.of_string s)
289 abate 10 let expr s = expr (Stream.of_string s)
290 abate 4 end
291    

CVS Admin">CVS Admin
ViewVC Help
Powered by ViewVC 1.1.5