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

Diff of /parser/parser.ml

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 4 by abate, Tue Jul 10 16:56:57 2007 UTC revision 26 by abate, Tue Jul 10 16:59:08 2007 UTC
# Line 1  Line 1 
1  open Location  open Location
2  open Ast  open Ast
3    
 module P = struct  
   
4    let gram    = Grammar.create (Plexer.make ())    let gram    = Grammar.create (Plexer.make ())
5      let prog    = Grammar.Entry.create gram "prog"
6    let expr    = Grammar.Entry.create gram "expression"    let expr    = Grammar.Entry.create gram "expression"
7    let pat     = Grammar.Entry.create gram "type/pattern expression"    let pat     = Grammar.Entry.create gram "type/pattern expression"
8    let regexp  = Grammar.Entry.create gram "type/pattern regexp"    let regexp  = Grammar.Entry.create gram "type/pattern regexp"
9    let const   = Grammar.Entry.create gram "scalar constant"    let const   = Grammar.Entry.create gram "scalar constant"
10    
   let atom_nil = Types.mk_atom "nil"  
   
11    let rec multi_prod loc = function    let rec multi_prod loc = function
12      | [ x ] -> x      | [ x ] -> x
13      | x :: l -> mk loc (Prod (x, multi_prod loc l))      | x :: l -> mk loc (Prod (x, multi_prod loc l))
# Line 18  Line 15 
15    
16    let rec tuple loc = function    let rec tuple loc = function
17      | [ x ] -> x      | [ x ] -> x
18      | x :: l -> mk loc (Pair (x, tuple loc l))      | x :: l -> mk (x.loc) (Pair (x, tuple loc l))
19      | [] -> assert false      | [] -> assert false
20    
21      let char = mk noloc (Internal (Types.char Chars.any))
22      let string = Star (Elem char)
23    
24      let cst_nil =  mk noloc (Cst (Types.Atom Sequence.nil_atom))
25    
26      let seq_of_string s =
27        let rec aux accu i = if (i = 0) then accu else aux (s.[i-1]::accu) (i-1) in
28        aux [] (String.length s)
29    
30    
31    EXTEND    EXTEND
32    GLOBAL: expr pat regexp const;    GLOBAL: prog expr pat regexp const;
33    
34      prog: [
35        [ l = LIST0 [ p = phrase; ";;" -> mk loc p ]; EOI -> l ]
36      ];
37    
38      phrase: [
39        [ e = expr -> EvalStatement e
40        | "type"; x = UIDENT; "="; t = pat -> TypeDecl (x,t) ]
41      ];
42    
43    expr: [    expr: [
44      "top" RIGHTA      "top" RIGHTA
45      [ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))      [ "match"; e = SELF; "with"; b = branches -> mk loc (Match (e,b))
46      | "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))      | "map"; e = SELF; "with"; b = branches -> mk loc (Map (e,b))
47        | "transform"; e = SELF; "with"; b = branches ->
48            mk noloc (Op ("flatten", [mk loc (Map (e,b))]))
49      | "fun"; f = OPT LIDENT; "("; a = LIST1 arrow SEP ";"; ")";      | "fun"; f = OPT LIDENT; "("; a = LIST1 arrow SEP ";"; ")";
50        b = branches ->        b = branches ->
51          mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })          mk loc (Abstraction { fun_name = f; fun_iface = a; fun_body = b })
52        | "fun";  f = OPT LIDENT;
53          "("; arg = LIDENT; ":"; targ = pat; ")"; ":"; tres = pat ;
54          "="; body = expr ->
55            let fun_body = (mk noloc (Capture arg), body) in
56            mk loc (Abstraction { fun_name = f; fun_iface = [(targ,tres)];
57                                  fun_body = [fun_body] })
58      | (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->      | (p,e1) = let_binding; "in"; e2 = expr LEVEL "top"->
59          mk loc (Match (e1,[p,e2]))          mk loc (Match (e1,[p,e2]))
60      ]      ]
61    
62      |      |
63      [ e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))      [ LIDENT "flatten"; e = expr -> mk loc (Op ("flatten",[e]))
64        | e1 = expr; e2 = expr -> mk loc (Apply (e1,e2))
65      ]      ]
66    
67        |
68        [ e1 = expr; "+"; e2 = expr -> mk loc (Op ("+",[e1;e2]))
69        | e1 = expr; "@"; e2 = expr -> mk loc (Op ("@",[e1;e2])) ]
70        |
71        [ e1 = expr; "*"; e2 = expr -> mk loc (Op ("*",[e1;e2]))  ]
72        |
73        [ e = expr;  "."; l = [LIDENT | UIDENT] -> mk loc (Dot (e,Types.label l)) ]
74    
75      | "no_appl"      | "no_appl"
76      [ c = const -> mk loc (Cst c)      [ c = const -> mk loc (Cst c)
77      | "("; l = LIST1 expr SEP ","; ")" -> tuple loc l      | "("; l = LIST1 expr SEP ","; ")" -> tuple loc l
78      | "[";  l = LIST0 expr LEVEL "no_appl"; "]" ->      | "[";  l = LIST0 seq_elem; e = OPT [ ";"; e = expr -> e ]; "]" ->
79          tuple loc (l @ [mk noloc (Cst (Types.Atom atom_nil))])          let e = match e with Some e -> e | None -> cst_nil in
80      | "[";  l = LIST0 expr LEVEL "no_appl"; ";"; e = expr; "]" ->          let l = List.flatten l in
81          tuple loc (l @ [e])          tuple loc (l @ [e])
82      | "<"; t = expr_tag_spec; a = expr_attrib_spec; ">"; c = expr ->      | "<"; t = expr_tag_spec; a = expr_attrib_spec; ">"; c = expr ->
83          tuple loc [t;a;c]          tuple loc [t;a;c]
84      | "{"; r = [ expr_record_spec | -> mk loc (RecordLitt []) ]; "}" -> r      | "{"; r = [ expr_record_spec | -> mk loc (RecordLitt []) ]; "}" -> r
85        | "!"; t = pat -> mk loc (DebugTyper t)
86      | a = LIDENT -> mk loc (Var a)      | a = LIDENT -> mk loc (Var a)
87      ]      ]
88    
89    ];    ];
90    
91      seq_elem: [
92        [ x = STRING ->
93            let s = seq_of_string (Token.eval_string x) in
94            List.map
95              (fun c -> mk loc (Cst (Types.Char (Chars.Unichar.from_char c))))
96              s
97        | e = expr LEVEL "no_appl" -> [e]
98        ]
99      ];
100    
101    let_binding: [    let_binding: [
102      [ "let"; p = pat; "="; e = expr -> (p,e)      [ "let"; p = pat; "="; e = expr -> (p,e)
103      | "let"; "fun"; f = LIDENT; "("; a = LIST0 arrow SEP ";"; ")";      | "let"; "fun"; f = LIDENT; "("; a = LIST0 arrow SEP ";"; ")";
# Line 66  Line 110 
110    ];    ];
111    
112    arrow: [    arrow: [
113      [ t1 = pat LEVEL "prod"; "->"; t2 = pat -> (t1,t2)]      [ t1 = pat LEVEL "no_arrow"; "->"; t2 = pat -> (t1,t2)]
114    ];    ];
115    
116    branches: [    branches: [
# Line 74  Line 118 
118    ];    ];
119    
120    branch: [    branch: [
121      [ p = pat; "->"; e = expr -> (p,e) ]      [ p = pat LEVEL "no_arrow"; "->"; e = expr -> (p,e) ]
122    ];    ];
123    
124    
# Line 89  Line 133 
133      | x = regexp; "?" -> Alt (x, Epsilon)      | x = regexp; "?" -> Alt (x, Epsilon)
134      | x = regexp; "??" -> Alt (Epsilon, x) ]      | x = regexp; "??" -> Alt (Epsilon, x) ]
135    | [ "("; x = regexp; ")" -> x    | [ "("; x = regexp; ")" -> x
136        | UIDENT "String" -> string
137        | s = STRING ->
138            let s = seq_of_string (Token.eval_string s) in
139            List.fold_right
140              (fun c accu ->
141                 let c = Chars.Unichar.from_char c in
142                 let c = Chars.atom c in
143                 Seq (Elem (mk loc (Internal (Types.char c))), accu))
144              s
145              Epsilon
146      | e = pat LEVEL "simple" -> Elem e      | e = pat LEVEL "simple" -> Elem e
147      ]      ]
148    ];    ];
# Line 98  Line 152 
152          b = LIST1 [ a = UIDENT; "="; y = pat -> (a,y)] SEP "and"          b = LIST1 [ a = UIDENT; "="; y = pat -> (a,y)] SEP "and"
153              -> mk loc (Recurs (x,b)) ]              -> mk loc (Recurs (x,b)) ]
154      | RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]      | RIGHTA [ x = pat; "->"; y = pat -> mk loc (Arrow (x,y)) ]
155      | [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ]      | "no_arrow" [ x = pat; "|"; y = pat -> mk loc (Or (x,y)) ]
156      | "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y))      | "simple" [ x = pat; "&"; y = pat -> mk loc (And (x,y))
157        | x = pat; "-"; y = pat -> mk loc (Diff (x,y)) ]        | x = pat; "-"; y = pat -> mk loc (Diff (x,y)) ]
158      |      |
159        [ "{"; r = record_spec; "}" -> r        [ "{"; r = record_spec; "}" -> r
       | UIDENT "Any" -> mk loc (Internal Types.any)  
160        | LIDENT "_" -> mk loc (Internal Types.any)        | LIDENT "_" -> mk loc (Internal Types.any)
161        | a = LIDENT -> mk loc (Capture a)        | a = LIDENT -> mk loc (Capture a)
162        | "("; a = LIDENT; ":="; c = const; ")" -> mk loc (Constant (a,c))        | "("; a = LIDENT; ":="; c = const; ")" -> mk loc (Constant (a,c))
163        | a = UIDENT -> mk loc (PatVar a)        | a = UIDENT -> mk loc (PatVar a)
164        | i = INT ; "--"; j = INT ->        | i = INT ; "--"; j = INT ->
165            let i = int_of_string i and j = int_of_string j in            let i = Big_int.big_int_of_string i
166              and j = Big_int.big_int_of_string j in
167            mk loc (Internal (Types.interval i j))            mk loc (Internal (Types.interval i j))
168          | i = char ->
169              mk loc (Internal (Types.char (Chars.char_class i i)))
170          | i = char ; "--"; j = char ->
171              mk loc (Internal (Types.char (Chars.char_class i j)))
172        | c = const -> mk loc (Internal (Types.constant c))        | c = const -> mk loc (Internal (Types.constant c))
173        | "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l        | "("; l = LIST1 pat SEP ","; ")" -> multi_prod loc l
174        | "["; r = [ r = regexp -> r | -> Epsilon ];        | "["; r = [ r = regexp -> r | -> Epsilon ];
175               q = [ ";"; q = pat -> q               q = [ ";"; q = pat -> q
176                   | -> mk noloc (Internal (Types.atom atom_nil)) ];                   | -> mk noloc (Internal (Sequence.nil_type)) ];
177               "]" -> mk loc (Regexp (r,q))               "]" -> mk loc (Regexp (r,q))
178        | "<"; t = tag_spec; a = attrib_spec; ">"; c = pat ->        | "<"; t = tag_spec; a = attrib_spec; ">"; c = pat ->
179            multi_prod loc [t;a;c]            multi_prod loc [t;a;c]
# Line 130  Line 188 
188                      mk loc (Record (Types.label l,o,x))                      mk loc (Record (Types.label l,o,x))
189                  ] SEP ";" ->                  ] SEP ";" ->
190          match r with          match r with
191            | [] -> mk noloc (Internal Types.Record.any)            | [] -> mk loc (Internal Types.Record.any)
192            | h::t -> List.fold_left (fun t1 t2 -> mk noloc (And (t1,t2))) h t            | h::t -> List.fold_left (fun t1 t2 -> mk loc (And (t1,t2))) h t
193        ] ];        ] ];
194    
195      char:
196        [
197          [ c = CHAR -> Chars.Unichar.from_char (Token.eval_char c)
198          | "!"; i = INT -> Chars.Unichar.from_int (int_of_string i) ]
199        ];
200    
201    
202    const:    const:
203      [      [
204        [ i = INT -> Types.Integer (int_of_string i)        [ i = INT -> Types.Integer (Big_int.big_int_of_string i)
205        | x = STRING -> Types.String (Token.eval_string x)        | "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.mk_atom a)
206        | "`"; a = [LIDENT | UIDENT] -> Types.Atom (Types.mk_atom a) ]        | c = char -> Types.Char c ]
207      ];      ];
208    
209    tag_spec:    tag_spec:
210      [      [
211        [ a = [LIDENT | UIDENT] ->        [ LIDENT "_" -> mk loc (Internal (Types.atom (Atoms.any))) ]
212            mk loc (Internal (Types.atom (Types.mk_atom a))) ]      | [ a = [LIDENT | UIDENT] ->
213              mk loc (Internal (Types.atom (Atoms.atom (Types.mk_atom a)))) ]
214      | [ t = pat -> t ]      | [ t = pat -> t ]
215      ];      ];
216    
# Line 173  Line 239 
239      ];      ];
240  END  END
241    
242    let pat = Grammar.Entry.parse pat
243    let expr = Grammar.Entry.parse expr
244    let prog = Grammar.Entry.parse prog
245    
246    module From_string = struct
247      let pat s = pat (Stream.of_string s)
248      let expr s = expr (Stream.of_string s)
249  end  end
250    
 let pat_or_typ s = Grammar.Entry.parse P.pat (Stream.of_string s)  
   
 let expr s =  Grammar.Entry.parse P.expr (Stream.of_string s)  
Legend:
Removed from v.4  
changed lines
  Added in v.26
CVS Admin">CVS Admin
 ViewVC Help
Powered by ViewVC 1.1.5