← Back to branch summary

~ubuntu-branches/debian/sid/ocaml/sid

« back to all changes in this revision

Viewing changes to camlp4/Camlp4/Struct/Grammar/Parser.ml

  • Committer: Bazaar Package Importer
  • Author(s): Stéphane Glondu
  • Date: 2011-04-21 21:35:08 UTC
  • mfrom: (1.1.11 upstream) (12.1.14 sid)
  • Revision ID: james.westby@ubuntu.com-20110421213508-kg34453aqmb0moha
* Fixes related to -output-obj with g++ (in debian/patches):
  - add Declare-primitive-name-table-as-const-char
  - add Avoid-multiple-declarations-in-generated-.c-files-in
  - fix Embed-bytecode-in-C-object-when-using-custom: the closing
    brace for extern "C" { ... } was missing in some cases

Show diffs side-by-side

added added

removed removed

Lines of Context:
camlp4/Camlp4/Struct/Grammar/Parser.ml
24
24
  open Structure;
25
25
  open Sig.Grammar;
26
26
 
 
27
  module StreamOrig = Stream;
 
28
 
 
29
  value njunk strm n =
 
30
    for i = 1 to n do Stream.junk strm done;
 
31
 
 
32
  value loc_bp = Tools.get_cur_loc;
 
33
  value loc_ep = Tools.get_prev_loc;
 
34
  value drop_prev_loc = Tools.drop_prev_loc;
 
35
 
 
36
  value add_loc bp parse_fun strm =
 
37
    let x = parse_fun strm in
 
38
    let ep = loc_ep strm in
 
39
    let loc = Loc.merge bp ep in
 
40
    (x, loc);
 
41
 
 
42
  value stream_peek_nth strm n =
 
43
    let rec loop i = fun
 
44
      [ [x :: xs] -> if i = 1 then Some x else loop (i - 1) xs
 
45
      | [] -> None ]
 
46
    in
 
47
    loop n (Stream.npeek n strm);
 
48
 
 
49
  (* We don't want Stream's functions to be used implictly. *)
27
50
  module Stream = struct
28
 
    include Stream;
29
 
    value junk strm = Context.junk strm;
30
 
    value count strm = Context.bp strm;
 
51
    type t 'a = StreamOrig.t 'a;
 
52
    exception Failure = StreamOrig.Failure;
 
53
    exception Error = StreamOrig.Error;
 
54
    value peek = StreamOrig.peek;
 
55
    value junk = StreamOrig.junk;
 
56
 
 
57
    value dup strm =
 
58
      (* This version of peek_nth is off-by-one from Stream.peek_nth *)
 
59
      let peek_nth n =
 
60
        loop n (Stream.npeek (n + 1) strm) where rec loop n =
 
61
          fun
 
62
          [ [] -> None
 
63
          | [x] -> if n = 0 then Some x else None
 
64
          | [_ :: l] -> loop (n - 1) l ]
 
65
      in
 
66
      Stream.from peek_nth;
31
67
  end;
32
68
 
33
 
  value add_loc c bp parse_fun strm =
34
 
    let x = parse_fun c strm in
35
 
    let ep = Context.loc_ep c in
36
 
    let loc = Loc.merge bp ep in
37
 
    (x, loc);
 
69
  value try_parser ps strm =
 
70
    let strm' = Stream.dup strm in
 
71
    let r =
 
72
      try ps strm'
 
73
      with
 
74
      [ Stream.Error _ | Loc.Exc_located _ (Stream.Error _) ->
 
75
          raise Stream.Failure
 
76
      | exc -> raise exc ]
 
77
    in do {
 
78
      njunk strm (StreamOrig.count strm');
 
79
      r;
 
80
    };
38
81
 
39
82
  value level_number entry lab =
40
83
    let rec lookup levn =
73
116
    | _ -> raise Stream.Failure ]
74
117
  ;
75
118
 
76
 
  value continue entry loc a s c son p1 =
 
119
  value continue entry loc a s son p1 =
77
120
    parser
78
 
      [: a = (entry_of_symb entry s).econtinue 0 loc a c;
 
121
      [: a = (entry_of_symb entry s).econtinue 0 loc a;
79
122
        act = p1 ?? Failed.tree_failed entry a s son :] ->
80
123
        Action.mk (fun _ -> Action.getf act a)
81
124
  ;
82
125
 
83
126
  (* PR#4603, PR#4330, PR#4551:
84
 
     Here Context.loc_bp replaced Context.loc_ep to fix all these bugs.
 
127
     Here loc_bp replaced get_loc_ep to fix all these bugs.
85
128
     If you do change it again look at these bugs. *)
86
 
  value skip_if_empty c bp _ =
87
 
    if Context.loc_bp c = bp then Action.mk (fun _ -> raise Stream.Failure)
 
129
  value skip_if_empty bp strm =
 
130
    if loc_bp strm = bp then Action.mk (fun _ -> raise Stream.Failure)
88
131
    else
89
132
      raise Stream.Failure
90
133
  ;
91
134
 
92
 
  value do_recover parser_of_tree entry nlevn alevn loc a s c son =
 
135
  value do_recover parser_of_tree entry nlevn alevn loc a s son =
93
136
    parser
94
 
    [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) c :] -> a
95
 
    | [: a = skip_if_empty c loc :] -> a
 
137
    [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a
 
138
    | [: a = skip_if_empty loc :] -> a
96
139
    | [: a =
97
 
          continue entry loc a s c son
98
 
            (parser_of_tree entry nlevn alevn son c) :] ->
 
140
          continue entry loc a s son
 
141
            (parser_of_tree entry nlevn alevn son) :] ->
99
142
        a ]
100
143
  ;
101
144
 
102
145
 
103
 
  value recover parser_of_tree entry nlevn alevn loc a s c son strm =
 
146
  value recover parser_of_tree entry nlevn alevn loc a s son strm =
104
147
    if strict_parsing.val then raise (Stream.Error (Failed.tree_failed entry a s son))
105
148
    else
106
149
      let _ =
107
 
        if strict_parsing_warning.val then
108
 
          do {
 
150
        if strict_parsing_warning.val then begin
109
151
            let msg = Failed.tree_failed entry a s son;
110
152
            Format.eprintf "Warning: trying to recover from syntax error";
111
153
            if entry.ename <> "" then Format.eprintf " in [%s]" entry.ename else ();
112
154
            Format.eprintf "\n%s%a@." msg Loc.print loc;
113
 
        } else () in
114
 
      do_recover parser_of_tree entry nlevn alevn loc a s c son strm
 
155
        end else () in
 
156
      do_recover parser_of_tree entry nlevn alevn loc a s son strm
115
157
  ;
116
158
 
117
159
  value rec parser_of_tree entry nlevn alevn =
118
160
    fun
119
 
    [ DeadEnd -> fun _ -> parser []
120
 
    | LocAct act _ -> fun _ -> parser [: :] -> act
 
161
    [ DeadEnd -> parser []
 
162
    | LocAct act _ -> parser [: :] -> act
121
163
    | Node {node = Sself; son = LocAct act _; brother = DeadEnd} ->
122
 
        fun c ->
123
 
          parser [: a = entry.estart alevn c :] -> Action.getf act a
 
164
        parser [: a = entry.estart alevn :] -> Action.getf act a
124
165
    | Node {node = Sself; son = LocAct act _; brother = bro} ->
125
166
        let p2 = parser_of_tree entry nlevn alevn bro in
126
 
        fun c ->
127
 
          parser
128
 
          [ [: a = entry.estart alevn c :] -> Action.getf act a
129
 
          | [: a = p2 c :] -> a ]
 
167
        parser
 
168
        [ [: a = entry.estart alevn :] -> Action.getf act a
 
169
        | [: a = p2 :] -> a ]
130
170
    | Node {node = s; son = son; brother = DeadEnd} ->
131
171
        let tokl =
132
172
          match s with
138
178
            let ps = parser_of_symbol entry nlevn s in
139
179
            let p1 = parser_of_tree entry nlevn alevn son in
140
180
            let p1 = parser_cont p1 entry nlevn alevn s son in
141
 
            fun c ->
142
 
              parser bp [: a = ps c; act = p1 c bp a :] -> Action.getf act a
 
181
            fun strm ->
 
182
              let bp = loc_bp strm in
 
183
              match strm with parser
 
184
              [: a = ps; act = p1 bp a :] -> Action.getf act a
143
185
        | Some (tokl, last_tok, son) ->
144
186
            let p1 = parser_of_tree entry nlevn alevn son in
145
187
            let p1 = parser_cont p1 entry nlevn alevn last_tok son in
156
198
            let p1 = parser_of_tree entry nlevn alevn son in
157
199
            let p1 = parser_cont p1 entry nlevn alevn s son in
158
200
            let p2 = parser_of_tree entry nlevn alevn bro in
159
 
            fun c ->
160
 
              parser bp
161
 
              [ [: a = ps c; act = p1 c bp a :] -> Action.getf act a
162
 
              | [: a = p2 c :] -> a ]
 
201
            fun strm ->
 
202
              let bp = loc_bp strm in
 
203
              match strm with parser
 
204
              [ [: a = ps; act = p1 bp a :] -> Action.getf act a
 
205
              | [: a = p2 :] -> a ]
163
206
        | Some (tokl, last_tok, son) ->
164
207
            let p1 = parser_of_tree entry nlevn alevn son in
165
208
            let p1 = parser_cont p1 entry nlevn alevn last_tok son in
166
209
            let p1 = parser_of_token_list p1 tokl in
167
210
            let p2 = parser_of_tree entry nlevn alevn bro in
168
 
            fun c ->
169
 
              parser
170
 
              [ [: a = p1 c :] -> a
171
 
              | [: a = p2 c :] -> a ] ] ]
172
 
  and parser_cont p1 entry nlevn alevn s son c loc a =
 
211
            parser
 
212
            [ [: a = p1 :] -> a
 
213
            | [: a = p2 :] -> a ] ] ]
 
214
  and parser_cont p1 entry nlevn alevn s son loc a =
173
215
    parser
174
 
    [ [: a = p1 c :] -> a
175
 
    | [: a = recover parser_of_tree entry nlevn alevn loc a s c son :] -> a
 
216
    [ [: a = p1 :] -> a
 
217
    | [: a = recover parser_of_tree entry nlevn alevn loc a s son :] -> a
176
218
    | [: :] -> raise (Stream.Error (Failed.tree_failed entry a s son)) ]
177
219
  and parser_of_token_list p1 tokl =
178
220
    loop 1 tokl where rec loop n =
180
222
      [ [Stoken (tematch, _) :: tokl] ->
181
223
          match tokl with
182
224
          [ [] ->
183
 
              let ps c _ =
184
 
                match Context.peek_nth c n with
185
 
                [ Some (tok, _) when tematch tok -> do { Context.njunk c n; Action.mk tok }
 
225
              let ps strm =
 
226
                match stream_peek_nth strm n with
 
227
                [ Some (tok, _) when tematch tok -> (njunk strm n; Action.mk tok)
186
228
                | _ -> raise Stream.Failure ]
187
229
              in
188
 
              fun c ->
189
 
                parser bp [: a = ps c; act = p1 c bp a :] -> Action.getf act a
 
230
              fun strm ->
 
231
                let bp = loc_bp strm in
 
232
                match strm with parser
 
233
                [: a = ps; act = p1 bp a :] -> Action.getf act a
190
234
          | _ ->
191
 
              let ps c _ =
192
 
                match Context.peek_nth c n with
 
235
              let ps strm =
 
236
                match stream_peek_nth strm n with
193
237
                [ Some (tok, _) when tematch tok -> tok
194
238
                | _ -> raise Stream.Failure ]
195
239
              in
196
240
              let p1 = loop (n + 1) tokl in
197
 
              fun c ->
198
 
                parser [: tok = ps c; s :] ->
199
 
                  let act = p1 c s in Action.getf act tok ]
 
241
              parser [: tok = ps; s :] ->
 
242
                let act = p1 s in Action.getf act tok ]
200
243
      | [Skeyword kwd :: tokl] ->
201
244
          match tokl with
202
245
          [ [] ->
203
 
              let ps c _ =
204
 
                match Context.peek_nth c n with
 
246
              let ps strm =
 
247
                match stream_peek_nth strm n with
205
248
                [ Some (tok, _) when Token.match_keyword kwd tok ->
206
 
                    do { Context.njunk c n; Action.mk tok }
 
249
                    (njunk strm n; Action.mk tok)
207
250
                | _ -> raise Stream.Failure ]
208
251
              in
209
 
              fun c ->
210
 
                parser bp [: a = ps c; act = p1 c bp a :] -> Action.getf act a
 
252
              fun strm ->
 
253
                let bp = loc_bp strm in
 
254
                match strm with parser
 
255
                [: a = ps; act = p1 bp a :] -> Action.getf act a
211
256
          | _ ->
212
 
              let ps c _ =
213
 
                match Context.peek_nth c n with
 
257
              let ps strm =
 
258
                match stream_peek_nth strm n with
214
259
                [ Some (tok, _) when Token.match_keyword kwd tok -> tok
215
260
                | _ -> raise Stream.Failure ]
216
261
              in
217
262
              let p1 = loop (n + 1) tokl in
218
 
              fun c ->
219
 
                parser [: tok = ps c; s :] ->
220
 
                  let act = p1 c s in Action.getf act tok ]
 
263
              parser [: tok = ps; s :] ->
 
264
                let act = p1 s in Action.getf act tok ]
221
265
      | _ -> invalid_arg "parser_of_token_list" ]
222
266
  and parser_of_symbol entry nlevn =
223
267
    fun
224
268
    [ Smeta _ symbl act ->
225
269
        let act = Obj.magic act entry symbl in
226
270
        let pl = List.map (parser_of_symbol entry nlevn) symbl in
227
 
        fun c ->
228
 
          Obj.magic (List.fold_left (fun act p -> Obj.magic act (p c)) act pl)
 
271
          Obj.magic (List.fold_left (fun act p -> Obj.magic act p) act pl)
229
272
    | Slist0 s ->
230
273
        let ps = parser_of_symbol entry nlevn s in
231
 
        let rec loop c al =
 
274
        let rec loop al =
232
275
          parser
233
 
          [ [: a = ps c; s :] -> loop c [a :: al] s
 
276
          [ [: a = ps; s :] -> loop [a :: al] s
234
277
          | [: :] -> al ]
235
278
        in
236
 
        fun c -> parser [: a = loop c [] :] -> Action.mk (List.rev a)
 
279
        parser [: a = loop [] :] -> Action.mk (List.rev a)
237
280
    | Slist0sep symb sep ->
238
281
        let ps = parser_of_symbol entry nlevn symb in
239
282
        let pt = parser_of_symbol entry nlevn sep in
240
 
        let rec kont c al =
 
283
        let rec kont al =
241
284
          parser
242
 
          [ [: v = pt c; a = ps c ?? Failed.symb_failed entry v sep symb;
 
285
          [ [: v = pt; a = ps ?? Failed.symb_failed entry v sep symb;
243
286
               s :] ->
244
 
              kont c [a :: al] s
 
287
              kont [a :: al] s
245
288
          | [: :] -> al ]
246
289
        in
247
 
        fun c ->
248
 
          parser
249
 
          [ [: a = ps c; s :] -> Action.mk (List.rev (kont c [a] s))
250
 
          | [: :] -> Action.mk [] ]
 
290
        parser
 
291
        [ [: a = ps; s :] -> Action.mk (List.rev (kont [a] s))
 
292
        | [: :] -> Action.mk [] ]
251
293
    | Slist1 s ->
252
294
        let ps = parser_of_symbol entry nlevn s in
253
 
        let rec loop c al =
 
295
        let rec loop al =
254
296
          parser
255
 
          [ [: a = ps c; s :] -> loop c [a :: al] s
 
297
          [ [: a = ps; s :] -> loop [a :: al] s
256
298
          | [: :] -> al ]
257
299
        in
258
 
        fun c ->
259
 
          parser [: a = ps c; s :] -> Action.mk (List.rev (loop c [a] s))
 
300
        parser [: a = ps; s :] -> Action.mk (List.rev (loop [a] s))
260
301
    | Slist1sep symb sep ->
261
302
        let ps = parser_of_symbol entry nlevn symb in
262
303
        let pt = parser_of_symbol entry nlevn sep in
263
 
        let rec kont c al =
 
304
        let rec kont al =
264
305
          parser
265
 
          [ [: v = pt c;
 
306
          [ [: v = pt;
266
307
              a =
267
308
                parser
268
 
                [ [: a = ps c :] -> a
269
 
                | [: a = parse_top_symb' entry symb c :] -> a
 
309
                [ [: a = ps :] -> a
 
310
                | [: a = parse_top_symb entry symb :] -> a
270
311
                | [: :] ->
271
312
                    raise (Stream.Error (Failed.symb_failed entry v sep symb)) ];
272
313
              s :] ->
273
 
              kont c [a :: al] s
 
314
              kont [a :: al] s
274
315
          | [: :] -> al ]
275
316
        in
276
 
        fun c ->
277
 
          parser [: a = ps c; s :] -> Action.mk (List.rev (kont c [a] s))
 
317
        parser [: a = ps; s :] -> Action.mk (List.rev (kont [a] s))
278
318
    | Sopt s ->
279
319
        let ps = parser_of_symbol entry nlevn s in
280
 
        fun c ->
281
 
          parser
282
 
          [ [: a = ps c :] -> Action.mk (Some a)
283
 
          | [: :] -> Action.mk None ]
 
320
        parser
 
321
        [ [: a = ps :] -> Action.mk (Some a)
 
322
        | [: :] -> Action.mk None ]
 
323
    | Stry s ->
 
324
        let ps = parser_of_symbol entry nlevn s in
 
325
        try_parser ps
284
326
    | Stree t ->
285
327
        let pt = parser_of_tree entry 1 0 t in
286
 
        fun c ->
287
 
          parser bp [: (act, loc) = add_loc c bp pt :] ->
 
328
        fun strm ->
 
329
          let bp = loc_bp strm in
 
330
          match strm with parser
 
331
          [: (act, loc) = add_loc bp pt :] ->
288
332
            Action.getf act loc
289
 
    | Snterm e -> fun c -> parser [: a = e.estart 0 c :] -> a
 
333
    | Snterm e -> parser [: a = e.estart 0 :] -> a
290
334
    | Snterml e l ->
291
 
        fun c -> parser [: a = e.estart (level_number e l) c :] -> a
292
 
    | Sself -> fun c -> parser [: a = entry.estart 0 c :] -> a
293
 
    | Snext -> fun c -> parser [: a = entry.estart nlevn c :] -> a
 
335
        parser [: a = e.estart (level_number e l) :] -> a
 
336
    | Sself -> parser [: a = entry.estart 0 :] -> a
 
337
    | Snext -> parser [: a = entry.estart nlevn :] -> a
294
338
    | Skeyword kwd ->
295
 
        fun _ ->
296
 
          parser
297
 
          [: `(tok, _) when Token.match_keyword kwd tok :] -> Action.mk tok
 
339
        parser
 
340
        [: `(tok, _) when Token.match_keyword kwd tok :] ->
 
341
           Action.mk tok
298
342
    | Stoken (f, _) ->
299
 
        fun _ -> parser [: `(tok, _) when f tok :] -> Action.mk tok ]
300
 
  and parse_top_symb' entry symb c =
301
 
    parser_of_symbol entry 0 (top_symb entry symb) c
302
 
  and parse_top_symb entry symb =
303
 
    fun strm ->
304
 
      Context.call_with_ctx strm
305
 
        (fun c -> parse_top_symb' entry symb c (Context.stream c));
 
343
        parser
 
344
        [: `(tok,_) when f tok :] -> Action.mk tok ]
 
345
  and parse_top_symb entry symb strm =
 
346
    parser_of_symbol entry 0 (top_symb entry symb) strm;
306
347
 
307
348
  value rec start_parser_of_levels entry clevn =
308
349
    fun
309
 
    [ [] -> fun _ _ -> parser []
 
350
    [ [] -> fun _ -> parser []
310
351
    | [lev :: levs] ->
311
352
        let p1 = start_parser_of_levels entry (succ clevn) levs in
312
353
        match lev.lprefix with
320
361
            let p2 = parser_of_tree entry (succ clevn) alevn tree in
321
362
            match levs with
322
363
            [ [] ->
323
 
                fun levn c ->
324
 
                  parser bp
325
 
                  [: (act, loc) = add_loc c bp p2; strm :] ->
 
364
                fun levn strm ->
 
365
                  let bp = loc_bp strm in
 
366
                  match strm with parser
 
367
                  [: (act, loc) = add_loc bp p2; strm :] ->
326
368
                    let a = Action.getf act loc in
327
 
                    entry.econtinue levn loc a c strm
 
369
                    entry.econtinue levn loc a strm
328
370
            | _ ->
329
 
                fun levn c strm ->
330
 
                  if levn > clevn then p1 levn c strm
 
371
                fun levn strm ->
 
372
                  if levn > clevn then p1 levn strm
331
373
                  else
332
 
                    match strm with parser bp
333
 
                    [ [: (act, loc) = add_loc c bp p2 :] ->
 
374
                    let bp = loc_bp strm in
 
375
                    match strm with parser
 
376
                    [ [: (act, loc) = add_loc bp p2 :] ->
334
377
                        let a = Action.getf act loc in
335
 
                        entry.econtinue levn loc a c strm
336
 
                    | [: act = p1 levn c :] -> act ] ] ] ]
 
378
                        entry.econtinue levn loc a strm
 
379
                    | [: act = p1 levn :] -> act ] ] ] ]
337
380
  ;
338
381
 
339
382
  value start_parser_of_entry entry =
341
384
    match entry.edesc with
342
385
    [ Dlevels [] -> Tools.empty_entry entry.ename
343
386
    | Dlevels elev -> start_parser_of_levels entry 0 elev
344
 
    | Dparser p -> fun _ _ strm -> p strm ]
 
387
    | Dparser p -> fun _ -> p ]
345
388
  ;
346
389
  value rec continue_parser_of_levels entry clevn =
347
390
    fun
348
 
    [ [] -> fun _ _ _ _ -> parser []
 
391
    [ [] -> fun _ _ _ -> parser []
349
392
    | [lev :: levs] ->
350
393
        let p1 = continue_parser_of_levels entry (succ clevn) levs in
351
394
        match lev.lsuffix with
357
400
              | RightA -> clevn ]
358
401
            in
359
402
            let p2 = parser_of_tree entry (succ clevn) alevn tree in
360
 
            fun c levn bp a strm ->
361
 
              if levn > clevn then p1 c levn bp a strm
 
403
            fun levn bp a strm ->
 
404
              if levn > clevn then p1 levn bp a strm
362
405
              else
363
406
                match strm with parser
364
 
                [ [: act = p1 c levn bp a :] -> act
365
 
                | [: (act, loc) = add_loc c bp p2 :] ->
 
407
                [ [: act = p1 levn bp a :] -> act
 
408
                | [: (act, loc) = add_loc bp p2 :] ->
366
409
                    let a = Action.getf2 act a loc in
367
 
                    entry.econtinue levn loc a c strm ] ] ]
 
410
                    entry.econtinue levn loc a strm ] ] ]
368
411
  ;
369
412
 
370
413
  value continue_parser_of_entry entry =
372
415
    match entry.edesc with
373
416
    [ Dlevels elev ->
374
417
        let p = continue_parser_of_levels entry 0 elev in
375
 
        fun levn bp a c ->
 
418
        fun levn bp a ->
376
419
          parser
377
 
          [ [: a = p c levn bp a :] -> a
 
420
          [ [: a = p levn bp a :] -> a
378
421
          | [: :] -> a ]
379
 
    | Dparser _ -> fun _ _ _ _ -> parser [] ]
 
422
    | Dparser _ -> fun _ _ _ -> parser [] ]
380
423
  ;
381
424
 
382
425
end;